Mouse Over Image or button

[SQUIDD]

Hello all

I am struggling to work out how to best achieve this, or if its possible.
I want to show a user form as information if hovering over an image on a sheet, then close it when not hovering over it.
I would prefer a picture, but happy to work with something different.

Lets say the image is inserted on the sheet called JOB_OVERVIEW
And the userform to show and hide is called JOB_FINANCIALS

Whats my best route here, many thanks

Dave

 

[Jaafar Tribak]

Hi Dave,

Assuming the image is inserted in an ActiveX Image control (Image1) on the worksheet JOB_OVERVIEW , you could use the following code :

For a bare minimum code, add the following to the module behind the JOB_OVERVIEW worksheet.

Option Explicit

Private WithEvents I_UserForm As MSForms.UserForm

Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim IDisp As Object
    If I_UserForm Is Nothing Then
        Set IDisp = JOB_FINANCIALS
        Set I_UserForm = IDisp
        IDisp.Show vbModeless
    End If
End Sub

Private Sub I_UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Unload I_UserForm
    Set I_UserForm = Nothing
End Sub

 

[SQUIDD]

Hi Jaafar

Thanks so much for that, it works, but not quite as i expected.

If i hover over Image1 it shows my userform, then to get the userform to disappear i have to hover over the userform.

But that works for me. So thanks very much, neat idea.

Dave

 

[Jaafar Tribak]

Thanks so much for that, it works, but not quite as i expected.
If i hover over Image1 it shows my userform, then to get the userform to disappear i have to hover over the userform.

Ok - I see what you mean. I misunderstood your requirement.

Use this more elaborate code to accomplish what yopu want:

Code Assumptions:
- The image control is an ActiveX control and its name is Image1
- The Userform name is JOB_FINANCIALS


Code goes in the Module of the Worksheet where Image1 is embedded.

Option Explicit

Private WithEvents CmndBrsEvents As CommandBars

#If Win64 Then
    Const NULL_PTR = 0^
#Else
    Const NULL_PTR = 0&
#End If

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type RECT
    Left    As Long
    Top     As Long
    Right   As Long
    Bottom  As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#End If

'/ Image Name = Image1
'/ UserForm Name = JOB_FINANCIALS


Private Sub Image1_MouseMove( _
    ByVal Button As Integer, _
    ByVal Shift As Integer, _
    ByVal x As Single, _
    ByVal y As Single _
)

    Const SWP_NOSIZE = &H1, SWP_SHOWWINDOW = &H40, SM_CYVSCROLL = 20&
    Dim hForm As LongPtr
    Dim Offset As Long
    Dim tCurPos As POINTAPI, oObj As Object
    Dim tImageRectPx As RECT, tVisibleRangeRectPx As RECT
    Dim nLeft As Long, nTop As Long

    Call GetCursorPos(tCurPos)
    Set oObj = ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)
    If TypeName(oObj) = "Nothing" Then Exit Sub
    Call IUnknown_GetWindow(JOB_FINANCIALS, VarPtr(hForm))
    If IsWindowVisible(hForm) = 0& Then
        JOB_FINANCIALS.StartUpPosition = 0&
        Set CmndBrsEvents = Application.CommandBars
        tImageRectPx = GetObjRect(Me.Image1)
        With ActiveWindow.VisibleRange
            tVisibleRangeRectPx = GetObjRect(.Cells(.Rows.Count - 2&, .Columns.Count - 2&))
        End With
        Offset = GetSystemMetrics(SM_CYVSCROLL)
        With tImageRectPx
            If .Top >= tVisibleRangeRectPx.Top - PTtoPX(JOB_FINANCIALS.Height, True) - Offset Then
                nTop = .Top - PTtoPX(JOB_FINANCIALS.Height, True)
            Else
                nTop = .Bottom
            End If
            If .Left >= tVisibleRangeRectPx.Left - PTtoPX(JOB_FINANCIALS.Width, False) - Offset Then
                nLeft = .Left - PTtoPX(JOB_FINANCIALS.Width, False)
            Else
                nLeft = .Right
            End If
        End With
        Call SetWindowPos(hForm, NULL_PTR, nLeft, nTop, 0&, 0&, SWP_NOSIZE + SWP_SHOWWINDOW)
        JOB_FINANCIALS.Show vbModeless
        Call CmndBrsEvents_OnUpdate
    End If

End Sub

Private Sub CmndBrsEvents_OnUpdate()
    Dim tCurPos As POINTAPI, oObj As Object
    If Not ActiveWorkbook Is ThisWorkbook Then Exit Sub
    Call GetCursorPos(tCurPos)
    Set oObj = ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)
    On Error Resume Next
        If oObj.Name <> Me.Image1.Name Then
            Set CmndBrsEvents = Nothing
            Unload JOB_FINANCIALS
        End If
    On Error GoTo 0
End Sub

Private Function ScreenDPI(ByVal bVert As Boolean) As Long
    Const LOGPIXELSX As Long = 88&, LOGPIXELSY As Long = 90&
    Static lDPI(1&) As Long, hDC As LongPtr
    If lDPI(0&) = 0& Then
        hDC = GetDC(NULL_PTR)
        lDPI(0&) = GetDeviceCaps(hDC, LOGPIXELSX)
        lDPI(1&) = GetDeviceCaps(hDC, LOGPIXELSY)
        hDC = ReleaseDC(NULL_PTR, hDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long
    Const POINTSPERINCH As Long = 72&
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function

Private Function GetObjRect(ByVal Obj As Object) As RECT
    Dim oPane As Pane
    Set oPane = ThisWorkbook.Windows(1&).ActivePane
    With GetObjRect
        .Left = oPane.PointsToScreenPixelsX(Obj.Left)
        .Top = oPane.PointsToScreenPixelsY(Obj.Top)
        .Right = oPane.PointsToScreenPixelsX(Obj.Left + Obj.Width)
        .Bottom = oPane.PointsToScreenPixelsY(Obj.Top + Obj.Height)
    End With
End Function

 

[SQUIDD]

Hi Jaafar

Wow, that works absolutely perfectly. I never would have imagined so much code for the task.

Thankyou so much.

Dave

 

[Jaafar Tribak]

Wow, that works absolutely perfectly. I never would have imagined so much code for the task.

It was necessary to write most of that code to make up for the lack of a proper mouse-leave event.
Anyways, I am glad you have this resolved.