Option Explicit
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
#If Win64 Then
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
#End If
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
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 GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
#Else
Private Enum LongPtr
[_]
End Enum
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
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 GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
#End If
Private oPrevRange As Range, oForm As Object
Function MouseHover(ByVal imgFilePath As String)
Dim tCurPos As POINTAPI
Dim oCurObj As Range
Dim hForm As LongPtr
Set oForm = UserForm1
oForm.PictureSizeMode = fmPictureSizeModeStretch
Call IUnknown_GetWindow(oForm, VarPtr(hForm))
On Error Resume Next
Call GetCursorPos(tCurPos)
Set oCurObj = ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)
If oCurObj.Address <> oPrevRange.Address Then
If Len(Application.Caller) Then
If Len(Dir(imgFilePath)) Then
Call KillTimer(Application.hwnd, 0&)
Call SetTimer(Application.hwnd, 0&, 0&, AddressOf TimerProc)
oForm.Picture = LoadPicture(imgFilePath)
oForm.Show vbModeless
Call HideCaption(hForm)
Call PositionForm(hForm)
End If
End If
End If
Set oPrevRange = oCurObj
End Function
'_____________________________________________ Private Routines __________________________________________________
Private Sub TimerProc()
Dim oCurObjx As Range
Dim tCurPos As POINTAPI
On Error Resume Next
Call GetCursorPos(tCurPos)
Set oCurObjx = ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)
If GetAsyncKeyState(VBA.vbKeyEscape) Then
Unload oForm
Exit Sub
End If
If oCurObjx.Address <> oPrevRange.Address Then
Call KillTimer(Application.hwnd, 0&)
Set oPrevRange = Nothing
Unload oForm
End If
End Sub
Private Sub HideCaption(ByVal hwnd As LongPtr)
Const GWL_STYLE = &HFFF0, WS_CAPTION = &HC00000
Const GWL_EXSTYLE = (-20), WS_EX_DLGMODALFRAME = &H1&
Dim Style As LongPtr
Style = GetWindowLong(hwnd, GWL_STYLE)
Style = Style And Not WS_CAPTION
Call SetWindowLong(hwnd, GWL_STYLE, Style)
Style = GetWindowLong(hwnd, GWL_EXSTYLE)
Style = Style And Not (WS_EX_DLGMODALFRAME)
Call SetWindowLong(hwnd, GWL_EXSTYLE, Style)
Call DrawMenuBar(hwnd)
End Sub
Private Sub PositionForm(ByVal hwnd As LongPtr)
Const SWP_NOSIZE = &H1
Dim tRect As RECT
Dim tCurPos As POINTAPI
Call GetCursorPos(tCurPos)
Call GetWindowRect(hwnd, tRect)
With tCurPos
Call SetWindowPos( _
hwnd, -1, .x + 40&, .y - (tRect.Bottom - tRect.Top), _
0&, 0&, 0 + 0 + SWP_NOSIZE _
)
End With
End Sub
Private Sub Auto_Close()
Call KillTimer(Application.hwnd, 0&)
End Sub