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