Continued: Use VBA to show an image of cells in a pop up window

[rokusek]

Hello all, first time posting here so I hope I'm doing this right...not a beginner with VBA but for some reason I am having a mental block here and can't figure this out for some reason. I found this bit posted by BiocideJ in 2014 in response to a question about needing an image of cells to pop up when double clicked like a tooltip of sorts. This code is awesome however it works all over the worksheet, I need it to work on a specific range, let's say A1. I have tried replacing the activesheet with a range and I've tried naming a range and calling it and it does not work...I hoping someone here can assist. TIA!

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim ImgRange As Range
    'remove any picture images previously generated
    For Each Shape In ActiveSheet.Shapes
        If Left(Shape.Name, 7) = "Picture" Then
            Shape.Delete
        End If
    Next
    'pseudo-refresh window so partial image residuals don't show on screen
    Application.WindowState = Application.WindowState

    'You will need to set this range dynamically based on
[B]   Set ImgRange = Range("J5:L13")[/B]
   
    'shows the Range as it would display for printing.
    'Change xlPrinter to xlScreen to show as it appears on the screen
    ImgRange.CopyPicture xlPrinter, xlPicture
    
    ActiveSheet.Paste Destination:=Target.Offset(0, 1)
    
    With ActiveSheet.Shapes.Range(1)
        .Line.Visible = msoTrue
        .Line.ForeColor.RGB = RGB(100, 100, 100)
        .Line.Transparency = 0
        .Fill.Visible = msoTrue
        .Fill.ForeColor.RGB = RGB(255, 255, 255)
        .Fill.Transparency = 0
        .Fill.Solid
    End With
End Sub

 

[Fluff]

Try adding this line after the Dim Statement

    If Target.Address(0, 0) <> "A1" Then Exit Sub

 

[6StringJazzer]

If you want this to work only if you double-click A1, then add this line at the top:

If Target.Address <> "$A$1" Then Exit Sub

 

[rokusek]

Y'all are awesome! It's getting there...I need it to disappear when clicking on another cell

 

[rokusek]

Y'all are awesome! It's getting there...I need it to disappear when clicking on another cell

Nevermind...I got it

 

[Fluff]

Glad we could help & thanks for the feedback.

 

[rokusek]

I moved the suggested code to after the for each shape in active sheet and changed it from a double click to a selectionchange and it works nicely however it then selects the image and instead of staying on the selected range...

I swear I'm not normally this lost but for some reason I can't brain too easily today lol

 

[Fluff]

You could add this to the end of the sub

    Application.EnableEvents = False
    Range("A1").Select
    Application.EnableEvents = True

 

[rokusek]

thanks all for your help on this, I did some updating to the suggested code and here is the update...the only disadvantage I am seeing at this point is it runs a bit slow, I may just explore a hover over method with and activeX box, I just hate the idea of imbedding an object over data

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim ImgRange As Range

    For Each Shape In ActiveSheet.Shapes
        If Left(Shape.Name, 7) = "Picture" Then
            Shape.Delete
        End If
    Next

    If Intersect(Target, Range("test")) Is Nothing Then Exit Sub

    Set ImgRange = Range("J5:K6")
   
    ImgRange.CopyPicture xlPrinter, xlPicture
    
    ActiveSheet.Paste Destination:=Target.Offset(0, 1)
    
    With ActiveSheet.Shapes.Range(1)
        .Line.Visible = msoTrue
        .Line.ForeColor.RGB = RGB(100, 100, 100)
        .Line.Transparency = 1
        .Fill.Visible = msoTrue
        .Fill.ForeColor.RGB = RGB(255, 255, 255)
        .Fill.Transparency = 1
        .Fill.Solid
    End With
    
    Application.EnableEvents = False
    Intersect(Target, Range("test")).Select
    Application.EnableEvents = True

End Sub

 

[Fluff]

Glad you sorted it & thanks for the feedback.