Hide image & pop up when mouseover

P

prajay

New Member
Joined
Sep 2, 2018
Messages
10
Dear team,

How to add picture into cell & resize automatically to cell size & should be hide & pop up when mouse over again hide when cursor removed from cell
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
Sort by date Sort by votes
Cells and pictures do not have mouseover events but a cell Comment does display on mouseover

Below is code which
- inserts picture Image1.jpg in comment of cell E3
- resizes comment to size of cell

Code: 
Sub InsertPicture()
    Dim fName   As String:          fName = "[COLOR=#2f4f4f]C:\Test\jpgFiles\[I]Image1[/I].jpg[/COLOR]"
    Dim cel     As Range:           Set cel = Range("[COLOR=#ff0000]E3[/COLOR]")
    On Error Resume Next
    cel.Comment.Delete
    cel.AddComment
    With cel.Comment.Shape
        .Fill.UserPicture fName
        .Height = cel.Height
        .Width = cel.Width
    End With
End Sub
 
Last edited:
Upvote 0
This is closer to what you want but is more complicated
- as mentioned above, mouseMove events are not available for cells
- mouseMove events are available for active-X controls
- this method uses an active-X Image Control
- the picture is displayed for a few seconds when mouse hovers over image

To test, follow instrctions below in the same sequence
- mouseMove code may fail if code is inserted in code module before control inserted in sheet

In a NEW a new worksheet
- click on developer tab
- insert Active-X Image Control (any size, anywhere) in worksheet
- look in Name Box and expect name Image1
- switch-off Design Mode (code will not run if in Design Mode)
- paste code below into SHEET module (it will not work if placed in Standard or ThisWorkbook module)
- amend full path to image
- go back to Excel
- test by hovering over Image Contol

Code: 
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim N As String, T As Double, Pic As Object, Cel As Range
    N = "[I][COLOR=#ff0000]C:\Test\folder\Image1.jpg[/COLOR][/I]"       '[COLOR=#006400][I]Amend this[/I][/COLOR]
    T = Timer
    Set Pic = Image1
    Set Cel = Range("[COLOR=#0000ff]E5[/COLOR]")
    Call SetProperties(Cel, Pic)
    Pic.Picture = LoadPicture(N)
    Do While Timer < (T + [COLOR=#0000ff]1[/COLOR]):     DoEvents:       Loop
    Pic.Picture = LoadPicture("")
End Sub

Private Sub SetProperties(Cel As Range, Obj As Object)
[COLOR=#0000ff]    Cel.ColumnWidth = 20
    Cel.RowHeight = 50[/COLOR]
    
    With Obj
        .Left = Cel.Left
        .Top = Cel.Top
        .Width = Cel.Width
        .Height = Cel.Height
        .PictureSizeMode = fmPictureSizeModeStretch
    End With
End Sub

I have set a few things (in blue) in the code to make it easier for you to test quickly
- amend after testing to match your requirements
 
Last edited:
Upvote 0
Here is another way :

1- Add a new Class module and give the Class the name of: C_ImageGenerator

Put this code In the Class Module :
Code: 
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private WithEvents oCmndBars As CommandBars
Private sTargetRangeAddr As String, sImageFileName As String



Public Sub AddPopUpImageToRange(ByVal Rng As Range, ByVal ImageFileName As String)
    sTargetRangeAddr = Rng.Address(, , , True)
    sImageFileName = ImageFileName
    If Len(Dir(ImageFileName)) = 0 Then Err.Raise Number:=vbObjectError + 513, Description:="Unable to find file : '" & ImageFileName & "'"
    Set oCmndBars = Application.CommandBars
    Call oCmndBars_OnUpdate
End Sub


Private Sub oCmndBars_OnUpdate()

    Dim oImage As Shape, tCurPos As POINTAPI

    Application.CommandBars.FindControl(ID:=2040).Enabled = Not Application.CommandBars.FindControl(ID:=2040).Enabled
    GetCursorPos tCurPos
    On Error Resume Next
         If Union(ActiveWindow.RangeFromPoint(tCurPos.X, tCurPos.Y), Range(sTargetRangeAddr)).Address(, , , True) = sTargetRangeAddr Then
        If Err.Number = 0 Then
            Set oImage = Range(sTargetRangeAddr).Parent.Shapes.AddPicture _
            (Filename:=sImageFileName, LinktoFile:=msoFalse, SaveWithDocument:=msoTrue, _
            Left:=Range(sTargetRangeAddr).Left, Top:=Range(sTargetRangeAddr).Top, _
            Width:=Range(sTargetRangeAddr).Width, Height:=Range(sTargetRangeAddr).Height)
            With oImage
                .Name = sTargetRangeAddr
                .Visible = True
            End With
        End If
    Else
        ActiveSheet.Shapes(sTargetRangeAddr).Delete
    End If

End Sub


2- Code Usage example in a Standard Module :
Code: 
Option Explicit

Private oImageGenerator1 As New C_ImageGenerator
Private oImageGenerator2 As New C_ImageGenerator
Private oImageGenerator3 As New C_ImageGenerator


Sub AddPopUps()

    Call oImageGenerator1.AddPopUpImageToRange _
    (Rng:=[COLOR=#ff0000]Sheet1[/COLOR][COLOR=#0000ff].Range("B2:F10")[/COLOR], ImageFileName:="C:\Users\Test\[COLOR=#ff0000]Image1[/COLOR].bmp")
    
    Call oImageGenerator2.AddPopUpImageToRange _
    (Rng:=[COLOR=#ff0000]Sheet1[/COLOR][COLOR=#0000ff].Range("G20")[/COLOR], ImageFileName:="C:\Users\Test\[COLOR=#ff0000]Image2[/COLOR].bmp")
    
    Call oImageGenerator3.AddPopUpImageToRange _
    (Rng:=[COLOR=#ff0000]Sheet2[/COLOR][COLOR=#0000ff].Range("A6")[/COLOR], ImageFileName:="C:\Users\Test\[COLOR=#ff0000]Image3[/COLOR].bmp")

End Sub

Sub RemovePopUps()

    Set oImageGenerator1 = Nothing
    Set oImageGenerator2 = Nothing
    Set oImageGenerator3 = Nothing

End Sub

This approach enables to flexibly add as many popup images as you like to different ranges in different sheets
 
Last edited:
Upvote 0
@Jaafar Tribak
Your code worked flawlessly the first time AddPopUps ran :smile:
The OP appears to be taking some time out, but I am still monitoring this thread
I hope OP is still interested because it is exactly was was requested

It would be useful if the user could click on the image to trigger another macro
- how could that functionality be added?

@prajay
After following instructions in post#4 run AddPopUps to get the mouseover to work
- those settings are lost whenever the workbook is closed

To ensure the mouseover is triggered automatically when workbook is re-opened insert this code in ThisWorkbook module
(It does not work if placed in a standard module)
Code: 
Private Sub Workbook_Open()
    Call AddPopUps
End Sub
 
Last edited:
Upvote 0
@Yongle
It would be useful if the user could click on the image to trigger another macro
- how could that functionality be added?
Click to expand...

You could easily add that functionality just by adding a third Optional argument to the AddPopUpImageToRange Method of the Class ... This third argument would hold the name of the Macro to be assigned to the popup image.

1- The Class Module would look like this :
Code: 
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private WithEvents oCmndBars As CommandBars
Private sTargetRangeAddr As String, sImageFileName As String
Private sMacroName As String



Public Sub AddPopUpImageToRange(ByVal Rng As Range, ByVal ImageFileName As String, Optional ClickMacro As String)
    sTargetRangeAddr = Rng.Address(, , , True)
    sImageFileName = ImageFileName
    sMacroName = ClickMacro
    If Len(Dir(ImageFileName)) = 0 Then Err.Raise Number:=vbObjectError + 513, Description:="Unable to find file : '" & ImageFileName & "'"
    Set oCmndBars = Application.CommandBars
    Call oCmndBars_OnUpdate
End Sub


Private Sub oCmndBars_OnUpdate()

    Dim oImage As Shape, tCurPos As POINTAPI

    Application.CommandBars.FindControl(ID:=2040).Enabled = Not Application.CommandBars.FindControl(ID:=2040).Enabled
    GetCursorPos tCurPos
    On Error Resume Next
     If Union(ActiveWindow.RangeFromPoint(tCurPos.X, tCurPos.Y), Range(sTargetRangeAddr)).Address(, , , True) = sTargetRangeAddr Then
        If Err.Number = 0 Then
            Set oImage = Range(sTargetRangeAddr).Parent.Shapes.AddPicture _
            (Filename:=sImageFileName, LinktoFile:=msoFalse, SaveWithDocument:=msoTrue, _
            Left:=Range(sTargetRangeAddr).Left, Top:=Range(sTargetRangeAddr).Top, _
            Width:=Range(sTargetRangeAddr).Width, Height:=Range(sTargetRangeAddr).Height)
            With oImage
                .Name = sTargetRangeAddr
                .Visible = True
                If Len(sMacroName) Then .OnAction = "'" & sMacroName & Chr(34) & "IMAGE_" & Split(.Name, "]")(1) & Chr(34) & "'"
            End With
        End If
    Else
        ActiveSheet.Shapes(sTargetRangeAddr).Delete
    End If

End Sub


2- Then in the Standard Module :
Code: 
Option Explicit

Private oImageGenerator1 As New C_ImageGenerator
Private oImageGenerator2 As New C_ImageGenerator
Private oImageGenerator3 As New C_ImageGenerator


Sub AddPopUps()

    Call oImageGenerator1.AddPopUpImageToRange _
    (Rng:=Sheet1.Range("B2:F10"), ImageFileName:="C:\Users\Info-Hp\Pictures\Image1.bmp", ClickMacro:="Macro")
    
    Call oImageGenerator2.AddPopUpImageToRange _
    (Rng:=Sheet1.Range("G20"), ImageFileName:="C:\Users\Info-Hp\Pictures\Image2.bmp", ClickMacro:="Macro")

    Call oImageGenerator3.AddPopUpImageToRange _
    (Rng:=Sheet2.Range("A6"), ImageFileName:="C:\Users\Info-Hp\Pictures\Image3.bmp")

End Sub


Sub RemovePopUps()

    Set oImageGenerator1 = Nothing
    Set oImageGenerator2 = Nothing
    Set oImageGenerator3 = Nothing

End Sub


Sub Macro(ByVal ImageName As String)
    MsgBox "You Clicked :" & vbNewLine & vbNewLine & ImageName, vbInformation
End Sub
 
Last edited:
Upvote 0
@Yongle

There is a subtle logic bug in the previous Class code which causes the popup image to not disappear when fast moving the mouse, so please ignore the last code and use this new version instead :

1- Class Code : (C_ImageGenerator)
Code: 
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private WithEvents oCmndBars As CommandBars
Private sTargetRangeAddr As String, sImageFileName As String
Private sMacroName As String



Public Sub AddPopUpImageToRange(ByVal Rng As Range, ByVal ImageFileName As String, Optional ClickMacro As String)
    sTargetRangeAddr = Rng.Address(, , , True)
    sImageFileName = ImageFileName
    sMacroName = ClickMacro
    If Len(Dir(ImageFileName)) = 0 Then Err.Raise Number:=vbObjectError + 513, Description:="Unable to find file : '" & ImageFileName & "'"
    Set oCmndBars = Application.CommandBars
    Call oCmndBars_OnUpdate
End Sub


Private Sub oCmndBars_OnUpdate()

    Dim oImage As Shape, tCurPos As POINTAPI

    Application.CommandBars.FindControl(ID:=2040).Enabled = Not Application.CommandBars.FindControl(ID:=2040).Enabled
    GetCursorPos tCurPos
    On Error Resume Next
    
     If Union(ActiveWindow.RangeFromPoint(tCurPos.X, tCurPos.Y), Range(sTargetRangeAddr)).Address(, , , True) = sTargetRangeAddr Then
        If Err.Number = 0 Then
            Set oImage = Range(sTargetRangeAddr).Parent.Shapes.AddPicture _
            (Filename:=sImageFileName, LinktoFile:=msoFalse, SaveWithDocument:=msoTrue, _
            Left:=Range(sTargetRangeAddr).Left, Top:=Range(sTargetRangeAddr).Top, _
            Width:=Range(sTargetRangeAddr).Width, Height:=Range(sTargetRangeAddr).Height)
            With oImage
                .Name = sTargetRangeAddr
                .Visible = True
                If Len(sMacroName) Then .OnAction = "'" & sMacroName & Chr(34) & "IMAGE_" & Split(.Name, "]")(1) & Chr(34) & "'"
            End With
        End If
    End If
    
    If ActiveWindow.RangeFromPoint(tCurPos.X, tCurPos.Y).Name <> sTargetRangeAddr Then
            ActiveSheet.Shapes(sTargetRangeAddr).Delete
    End If

End Sub


2- Class Usage example in a Standard Module :
Code: 
Option Explicit

Private oImageGenerator1 As New C_ImageGenerator
Private oImageGenerator2 As New C_ImageGenerator
Private oImageGenerator3 As New C_ImageGenerator


Sub AddPopUps()

    Call oImageGenerator1.AddPopUpImageToRange _
    (Rng:=Sheet1.Range("B2:F10"), ImageFileName:="C:\Users\Info-Hp\Pictures\Image1.bmp", ClickMacro:="Macro")
    
    Call oImageGenerator2.AddPopUpImageToRange _
    (Rng:=Sheet1.Range("G20"), ImageFileName:="C:\Users\Info-Hp\Pictures\Image2.bmp", ClickMacro:="Macro")

    Call oImageGenerator3.AddPopUpImageToRange _
    (Rng:=Sheet2.Range("A6"), ImageFileName:="C:\Users\Info-Hp\Pictures\Image3.bmp")

End Sub


Sub RemovePopUps()

    Set oImageGenerator1 = Nothing
    Set oImageGenerator2 = Nothing
    Set oImageGenerator3 = Nothing

End Sub


Sub Macro(ByVal ImageName As String)
    MsgBox "You Clicked :" & vbNewLine & vbNewLine & ImageName, vbInformation
End Sub
 
Last edited:
Upvote 0
@Yongle

lol ! I went too fast before properly testing - Again another bug went unnoticed.

Sorry for messing up the thread !


1- Class Code (C_ImageGenerator)
Code: 
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private WithEvents oCmndBars As CommandBars
Private sTargetRangeAddr As String, sImageFileName As String
Private sMacroName As String



Public Sub AddPopUpImageToRange(ByVal Rng As Range, ByVal ImageFileName As String, Optional ClickMacro As String)
    sTargetRangeAddr = Rng.Address(, , , True)
    sImageFileName = ImageFileName
    sMacroName = ClickMacro
    If Len(Dir(ImageFileName)) = 0 Then Err.Raise Number:=vbObjectError + 513, Description:="Unable to find file : '" & ImageFileName & "'"
    Set oCmndBars = Application.CommandBars
    Call oCmndBars_OnUpdate
End Sub


Private Sub oCmndBars_OnUpdate()

    Dim oImage As Shape, tCurPos As POINTAPI

    Application.CommandBars.FindControl(ID:=2040).Enabled = Not Application.CommandBars.FindControl(ID:=2040).Enabled
    GetCursorPos tCurPos
    On Error Resume Next
    
     If Union(ActiveWindow.RangeFromPoint(tCurPos.X, tCurPos.Y), Range(sTargetRangeAddr)).Address(, , , True) = sTargetRangeAddr Then
        If Err.Number = 0 Then
            Set oImage = Range(sTargetRangeAddr).Parent.Shapes.AddPicture _
            (Filename:=sImageFileName, LinktoFile:=msoFalse, SaveWithDocument:=msoTrue, _
            Left:=Range(sTargetRangeAddr).Left, Top:=Range(sTargetRangeAddr).Top, _
            Width:=Range(sTargetRangeAddr).Width, Height:=Range(sTargetRangeAddr).Height)
            With oImage
                .Name = sTargetRangeAddr
                .Visible = True
                .OnAction = "'" & sMacroName & Chr(34) & "IMAGE_" & Split(.Name, "]")(1) & Chr(34) & "'"
            End With
        End If
    End If
    
    If ActiveWindow.RangeFromPoint(tCurPos.X, tCurPos.Y).Name <> sTargetRangeAddr Then
            ActiveSheet.Shapes(sTargetRangeAddr).Delete
    End If

End Sub



2- Class usage code in a Standard Module :
Code: 
Option Explicit

Private oImageGenerator1 As New C_ImageGenerator
Private oImageGenerator2 As New C_ImageGenerator
Private oImageGenerator3 As New C_ImageGenerator


Sub AddPopUps()

    Call oImageGenerator1.AddPopUpImageToRange _
    (Rng:=Sheet1.Range("B2:F10"), ImageFileName:="C:\Users\Info-Hp\Pictures\Image1.bmp", ClickMacro:="Macro")
    
    Call oImageGenerator2.AddPopUpImageToRange _
    (Rng:=Sheet1.Range("G20"), ImageFileName:="C:\Users\Info-Hp\Pictures\Image2.bmp", ClickMacro:="Macro")

    Call oImageGenerator3.AddPopUpImageToRange _
    (Rng:=Sheet2.Range("A6"), ImageFileName:="C:\Users\Info-Hp\Pictures\Image3.bmp")

End Sub


Sub RemovePopUps()

    Set oImageGenerator1 = Nothing
    Set oImageGenerator2 = Nothing
    Set oImageGenerator3 = Nothing

End Sub


Sub Macro(ByVal ImageName As String)
    MsgBox "You Clicked :" & vbNewLine & vbNewLine & ImageName, vbInformation
End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Solved
Msbox VBA code when cell value is changed
2
Replies
18
Views
497
Ramadan2512
R
R
  • Solved
Mouseover and display image - is it possible?
Replies
3
Views
698
NdNoviceHlp
NdNoviceHlp
M
  • Question Question
Removing right-click menu items
Replies
4
Views
243
mcomp72
M
T
  • Question Question
Pop Up Message if specific cells are greater than other specific cells
Replies
5
Views
1K
tabs1063
T
S
  • Solved
VBA Code - Remove link to inserted pictures
Replies
5
Views
722
Domenic
D

Forum statistics

Threads
1,223,903
Messages
6,175,286
Members
452,631
Latest member
a_potato

Share this page

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
Back
Top