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

rokusek

New Member
Joined
May 6, 2022
Messages
6
Office Version
  1. 365
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!

VBA Code:
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
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
77,618
Office Version
  1. 365
Platform
  1. Windows
Try adding this line after the Dim Statement
VBA Code:
    If Target.Address(0, 0) <> "A1" Then Exit Sub
 

6StringJazzer

Well-known Member
Joined
Jan 27, 2010
Messages
2,384
Office Version
  1. 365
Platform
  1. Windows
  2. Mobile
If you want this to work only if you double-click A1, then add this line at the top:

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

rokusek

New Member
Joined
May 6, 2022
Messages
6
Office Version
  1. 365
Y'all are awesome! It's getting there...I need it to disappear when clicking on another cell
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
77,618
Office Version
  1. 365
Platform
  1. Windows
Glad we could help & thanks for the feedback.
 

rokusek

New Member
Joined
May 6, 2022
Messages
6
Office Version
  1. 365
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
77,618
Office Version
  1. 365
Platform
  1. Windows
You could add this to the end of the sub
VBA Code:
    Application.EnableEvents = False
    Range("A1").Select
    Application.EnableEvents = True
 

rokusek

New Member
Joined
May 6, 2022
Messages
6
Office Version
  1. 365
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

VBA Code:
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
77,618
Office Version
  1. 365
Platform
  1. Windows
Glad you sorted it & thanks for the feedback.
 

Forum statistics

Threads
1,175,794
Messages
5,899,527
Members
434,779
Latest member
Mr1510

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top