Double click a cell to show a picture from a link

[VBAHelpNeededPlease]

Hi there,

I have the following function that will display a picture if you run your mouse over it. It's quite neat, and works well. However, I'd like to change it from running your mouse over it, to a double click function.

Below is the code that works that will show a picture when you run a mouse over a cell:

Dim DoOnce As Boolean
Public Function OnMouseOver(URL As String, TheCell As Range)

DoOnce = True
    With ActiveSheet.Pictures.Insert(URL)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = 570
            .Height = 380
        End With
        .Left = Cells(TheCell.Row, TheCell.Column + 1).Left
        .Top = Cells(TheCell.Row, TheCell.Column + 1).Top
        .Placement = 1
        .PrintObject = True
    End With

End Function

And I know I need the below code, of sorts, that if you double click on it something will happen:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Address = "$A$1" Then
        'do something
    End If
    Cancel = True
End Sub

I just can't seem to merge the two - so that I get the functionality of the original code, but with needing a double click rather than just passing the mouse over the cell.

Would be a big help if I could get a hand with this.

Thanks,

 

[DanteAmor]

Hi and welcome to MrExcel.

If in cell A1 you put something the path and the name of the file where the image is, a comma and the cell where you want the image, for example:

varios 08jun2020.xlsm
	A
1	c:\trabajo\images\carla.jpg, E7
2
Hoja8

Double-clicking A1 looks for the coat image in the path "C:\trabajo\images" and puts it in cell E7.

Try this

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim URL As String, TheCell As Range

  If Target.Address(0, 0) = "A1" Then
    URL = Split(Target.Value, ",")(0)
    Set TheCell = Range(Split(Target.Value, ",")(1))
    With ActiveSheet.Pictures.Insert(URL)
      With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 570
        .Height = 380
      End With
      .Left = Cells(TheCell.Row, TheCell.Column + 1).Left
      .Top = Cells(TheCell.Row, TheCell.Column + 1).Top
      .Placement = 1
      .PrintObject = True
    End With
    Cancel = True
  End If
End Sub

 

[VBAHelpNeededPlease]

Hi Dante, thanks for the welcome, and the response - much appreciated!

I copied your code into a new macro enabled workbook and copied in the VBA module as a new module, and in cell A1 I put the link to a pic on my computer, but it didn't seem to work?

I double clicked on cell A1, and nothing happened - when I double clicked on the cell it went into text edit mode for the cell.

Not sure what is going on?

For reference, I got the initial code from here: Hover preview over excel image link

And have made the code work well for what I want to do with dragging the mouse over cells.

I should have mentioned this to start with, but there is another piece of the puzzle too:

I have a repetitive process, and would like to be able to drag and drop/copy this functionality to new cells/rows for a new process/picture.

For my picture address/URL, I am currently doing a concatenate =CONCATENATE("C:\","1.jpg") with the 1.jpg being variable for each new picture, and each new row/picture being 1, 2, 3 etc.

How could I do it so

Target.Address(0, 0) = "A1"

is not fixed - each new row that is copied and pasted for each new picture can look at the new picture address - without having to alter the VBA code each time?

I currently have that ability using the mouse over cell code.

Thanks,

Steve.

 

[DanteAmor]

Put the following in cell A1

varios 08jun2020.xlsm
	A	B
1	C:\1.jpg, B1
Hoja8

Put the following code in the events of the sheet.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim URL As String, TheCell As Range
  
  If Target.Address(0, 0) = "A1" Then
    URL = Trim(Split(Target.Value, ",")(0))
    Set TheCell = Trim(Range(Split(Target.Value, ",")(1)))
    With ActiveSheet.Pictures.Insert(URL)
      With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 570
        .Height = 380
      End With
      .Left = Cells(TheCell.Row, TheCell.Column + 1).Left
      .Top = Cells(TheCell.Row, TheCell.Column + 1).Top
      .Placement = 1
      .PrintObject = True
    End With
    Cancel = True
  End If
End Sub

SHEET EVENT
Right click the tab of the sheet you want this to work, select view code and paste the code into the window that opens up.

 

[VBAHelpNeededPlease]

Hi Dante, I got the code to work.
I am now just trying to make it dynamic - that is so it is not referencing cell A1 and I can drag and drop it.

In a module, could I put the following public functions?

Dim DoOnce As Boolean
Public Function PicLink(URL As String)
' This is the link to the pic eg C:\1.jpg
End Function

Public Function PicAddress(TheCell As Range)
'This is the location that the pic will be placed
End Function

I guess the trick is then making your code see PicLink and PicAddress? I read somewhere that you don't need to call a public function?

It would be ok if the the Target.Address = PicAddress too for simplicity.

With using the above public functions, the below code is what I would like to see work, but unfortunately doesn't.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim PicLink As String, PicAddress As Range
  
  If Target.Address = "PicAddress" Then
    URL = "PicLink"
      Set TheCell = Range("PicAddress")
           With ActiveSheet.Pictures.Insert(URL)
      With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 570
        .Height = 380
      End With
      .Left = Cells(TheCell.Row, TheCell.Column + 1).Left
      .Top = Cells(TheCell.Row, TheCell.Column + 1).Top
      .Placement = 1
      .PrintObject = True
    End With
    Cancel = True
  End If
End Sub

Any tips on how to finish this off??

Thanks,

Steve.

 

[DanteAmor]

if you want a bigger range try this:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim URL As String, TheCell As Range
  
  If Not Intersect(Target, Range("A:A, D:D")) Is Nothing Then
    URL = Trim(Split(Target.Value, ",")(0))
    Set TheCell = Trim(Range(Split(Target.Value, ",")(1)))
    With ActiveSheet.Pictures.Insert(URL)
      With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 570
        .Height = 380
      End With
      .Left = Cells(TheCell.Row, TheCell.Column + 1).Left
      .Top = Cells(TheCell.Row, TheCell.Column + 1).Top
      .Placement = 1
      .PrintObject = True
    End With
    Cancel = True
  End If
End Sub

 

[VBAHelpNeededPlease]

Hi Dante,

I got that to work, over the larger range.

One thing I did need to change though:

Set TheCell = Trim(Range(Split(Target.Value, ",")(1)))

into

Set TheCell = Range(Trim(Split(Target.Value, ",")(1)))

Dante, I have one last question with this, so I can do what I need to do:

Can I make this work from an action box, that is separate to the information address box? So I am clicking on a separate box that doesn't have the file location information in it.

An example pic of what this would look like is attached.

I have tried to do something with the intersect function, that would intersect the row that the action box is on, with the column in which the location information resides, but I haven't got that to work.

Many thanks - for what should be the last piece of this puzzle!

Steve.

 

[DanteAmor]

It will always be in column A and the file information in column D, in the same row?
There must be a pattern, it cannot be clicked on A5 and the cell with information on Z24.
click on A6 and the cell on W80
click on A7 and the cell on F3, can I explain?

 

[VBAHelpNeededPlease]

Hi Dante,

yes, roughly that. Activation button in column A, and the information in column D. The columns of these locations will not change.

This format will then be repeated/copied/draged and dropped downwards on more rows for more pictures as required.

Thanks,

Steve.

 

[DanteAmor]

Try this

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim URL As String, TheCell As Range
  
  If Not Intersect(Target, Range("A:A")) Is Nothing Then
    URL = Trim(Split(Cells(Target.Row, "D"), ",")(0))
    Set TheCell = Range(Trim(Split(Cells(Target.Row, "D"), ",")(1)))
    With ActiveSheet.Pictures.Insert(URL)
      With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 570
        .Height = 380
      End With
      .Left = Cells(TheCell.Row, TheCell.Column + 1).Left
      .Top = Cells(TheCell.Row, TheCell.Column + 1).Top
      .Placement = 1
      .PrintObject = True
    End With
    Cancel = True
  End If
End Sub