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,

 

[VBAHelpNeededPlease]

Dante that worked great!!

Thank you!

 

[VBAHelpNeededPlease]

Dante...

sorry, ONE last question. I didn't know that this would be an issue until I found it!

I need to have 3 double click actions in the workbook, two of the same for two different sets of pictures, and a picture clear function to delete the loaded pictures.

I tried just adding the different modules that i wanted underneath each other, but it came up with an error " ambiguous name detected " - I guess it's seeing two things with the same name.

I have seen this post here VBA - BeforeDoubleClick Multiple Ranges In One Code

and have tried my best to make it work - as shown below:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim URL As String, TheCell As Range, Pic As Object
  
  Select Case Target.Address
  
  Case "A:A"
    URL = Trim(Split(Cells(Target.Row, "X"), ",")(0))
    Set TheCell = Range(Trim(Split(Cells(Target.Row, "X"), ",")(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
    
    Case "B:B"
    URL = Trim(Split(Cells(Target.Row, "Y"), ",")(0))
    Set TheCell = Range(Trim(Split(Cells(Target.Row, "Y"), ",")(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
    
    Case "C:16"
For Each Pic In ActiveSheet.Pictures
Pic.Delete
Next Pic
Cancel = True
On Error Resume Next
   
    
    Case Else
    Exit Sub
    
  End Select
  
  End Sub

When I click on a target cell, a picture does not come up, nor can i clear a picture that is in the worksheet either.

The

cancel=true

doesn't seem to work either, as after the double click it then goes into text modify in the cell.

The code doesn't display any error codes requiring attention/debugging in VBA - but it also just doesn't do what it should and provide the required actions.

Thanks, and sorry for moving the goalposts.

Steve.

 

[DanteAmor]

If I understand correctly, if you press double click in column A, look in column X, if B in "Y" and if it is cell C16, delete all.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim URL As String, TheCell As Range, col As String
  
  If Not Intersect(Target, Range("A:A, B:B, C16")) Is Nothing Then
    Cancel = True
    Select Case True
      Case Target.Column = 1: col = "X"
      Case Target.Column = 2: col = "Y"
      Case Target.Address(0, 0) = "C16"
        ActiveSheet.Pictures.Delete
        Exit Sub
    End Select
    
    URL = Trim(Split(Cells(Target.Row, col), ",")(0))
    Set TheCell = Range(Trim(Split(Cells(Target.Row, col), ",")(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
  End If
End Sub

 

[VBAHelpNeededPlease]

Dante,

just tried that code and it is PERFECT!

THANK YOU

Cheers,

Steve

 

[DanteAmor]

Im glad to help you, thanks for the feedback.

 

[VBAHelpNeededPlease]

Dante,

it seems to be a great thing that you can't close questions off on here.

The above code works - but - I need to have 3 different picture control mechanisms for the different picture types.

If have tried to do this with an if statement - using the target column, eg Target.Column = 1 to identify the different pictures.

I can get it to run without an error, but it doesn't produce the goods?

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim URL As String, TheCell As Range, col As String
  
  If Not Intersect(Target, Range("H15:H5015, L15:L5015, F15:F5015,  F1:M1")) Is Nothing Then
    Cancel = True
    Select Case True
      Case Target.Column = 1: col = "Q"
      Case Target.Column = 2: col = "S"
      Case Target.Column = 3: col = "U"
      Case Target.Address(0, 0) = "F1:M1"
        ActiveSheet.Pictures.Delete
        Exit Sub
    End Select
    
     '1 pictures
     If Target.Column = 1 Then
   URL = Trim(Split(Cells(Target.Row, col), ",")(0))
    Set TheCell = Range(Trim(Split(Cells(Target.Row, col), ",")(1)))
    With ActiveSheet.Pictures.Insert(URL)
      With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 600
        .Height = 400
      End With
      .Left = Cells(TheCell.Row, TheCell.Column - 7).Left
      .Top = Cells(TheCell.Row, TheCell.Column + 1).Top
      .Placement = 1
      .PrintObject = True
    End With
    End If
    
    '2 Pictures
    If Target.Column = 2 Then
    URL = Trim(Split(Cells(Target.Row, col), ",")(0))
    Set TheCell = Range(Trim(Split(Cells(Target.Row, col), ",")(1)))
    With ActiveSheet.Pictures.Insert(URL)
      With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 675
        .Height = 450
      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 If
        
    '3 pictures
    If Target.Column = 3 Then
    URL = Trim(Split(Cells(Target.Row, col), ",")(0))
    Set TheCell = Range(Trim(Split(Cells(Target.Row, col), ",")(1)))
    With ActiveSheet.Pictures.Insert(URL)
      With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 450
        .Height = 300
      End With
      .Left = Cells(TheCell.Row, TheCell.Column - 4).Left
      .Top = Cells(TheCell.Row, TheCell.Column + 1).Top
      .Placement = 1
      .PrintObject = True
    End With
    End If
                  
  End If
End Sub

Could you please have a look?

Thanks,

Steve

 

[DanteAmor]

If Not Intersect(Target, Range("A:A, B:B, C16")) Is Nothing Then
...
Case Target.Column = 1: col = "X"

I see that you like to learn.
This is the logic of the cell where you press double click.
"A" is target.column 1, "B" is column 2, and so on.

If Not Intersect(Target, Range("H15:H5015, L15:L5015, F15:F5015, F1:M1")) Is Nothing Then

In this case, "H" is 8, "L" is 12, "F" is 6

Try and tell me.

 

[VBAHelpNeededPlease]

Hi Dante,

yes, I do like to learn. Trying to get better at it!

The advice that you supplied above worked great!

I now have what I need - thank you very much for your help with this - and your patience.

Cheers,

Steve.

 

[DanteAmor]

Again with pleasure. Thanks for the feedback

 

[steb]

If I understand correctly, if you press double click in column A, look in column X, if B in "Y" and if it is cell C16, delete all.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim URL As String, TheCell As Range, col As String
 
  If Not Intersect(Target, Range("A:A, B:B, C16")) Is Nothing Then
    Cancel = True
    Select Case True
      Case Target.Column = 1: col = "X"
      Case Target.Column = 2: col = "Y"
      Case Target.Address(0, 0) = "C16"
        ActiveSheet.Pictures.Delete
        Exit Sub
    End Select
   
    URL = Trim(Split(Cells(Target.Row, col), ",")(0))
    Set TheCell = Range(Trim(Split(Cells(Target.Row, col), ",")(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
  End If
End Sub

I tried with this code but it doesn't seem to work. There's always an error returned in this line:

URL = Trim(Split(Cells(Target.Row, col), ",")(0))

My objective is simplier than OP's. Just to preview an image link (not local one) by double clicking a link, and remove the loaded image by clicking it again (or hovering upon it, both good to me). Also, clicking any colum H to show the image in column I.

Would be much appreciated if someone could help