Option Explicit
' SOURCE:
' https://www.mrexcel.com/board/threads/can-excel-unhide-hide-rows-just-by-hovering-a-mouse-over-it.1124546/
' https://www.mrexcel.com/board/threads/help-with-form-positioner.156485/page-2#post-767451
' https://www.mrexcel.com/board/threads/workbook-beforeclose-cancel-button.1054190/#post-5062639
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (ByRef 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 GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hwnd As LongPtr, ByVal dwId As Long, ByRef riid As GUID, ByRef ppvObject As Any) As Long
Private Declare PtrSafe Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, lpiid As GUID) As Long
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private hHook As LongPtr
#Else
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hwnd As Long, ByVal dwId As Long, ByRef riid As GUID, ByRef ppvObject As Any) As Long
Private Declare Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, lpiid As GUID) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private hHook As Long
#End If
Private Const POINTSPERINCH As Long = 72
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const CUSTOMIZEDINTERVAL As Long = 200
Private Const WH_CBT As Long = 5
Private Const HCBT_DESTROYWND As Long = 4
Private Const CHILDID_SELF As Long = &H0&
Private Const NAVDIR_FIRSTCHILD As Long = &H7&
Private Const NAVDIR_NEXT As Long = &H5&
Private Const S_OK As Long = &H0&
Private Const OBJID_CLIENT As Long = &HFFFFFFFC
Private Const IID_IAccessible As String = "{618736E0-3C3D-11CF-810C-00AA00389B71}"
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type TLOCALS
CursorPos As POINTAPI
ToolTipProvider As CRangeToolTip
xlWndTitle As String
PixelsPerPointX As Single
PixelsPerPointY As Single
PointsPerPixelX As Single
PointsPerPixelY As Single
hDC As Long
End Type
Private This As TLOCALS
Public Enum RelativePosition
TopLeft
TopRight
BottomLeft
BottomRight
End Enum
#If VBA7 Then
Private Sub TickTock(ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long)
#Else
Private Sub TickTock(ByVal hwnd As Long, ByVal wMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
#End If
Dim DisplayOnPos As POINTAPI, CurWnd As Excel.Window, Rng As Excel.Range, Shp As Excel.Shape
On Error Resume Next
If GetActiveWindow <> 0 Then
Set CurWnd = Excel.Application.ActiveWindow
If CurWnd.Caption = This.xlWndTitle Then
If CurWnd.WindowState <> xlMinimized Then
GetCursorPos This.CursorPos
With This.CursorPos
Set Rng = CurWnd.RangeFromPoint(.x, .y)
DisplayOnPos = PointOnScreen(Rng, TopRight)
This.ToolTipProvider.OnMouseMove Rng, DisplayOnPos.y, DisplayOnPos.x
Set Shp = Nothing
Set Shp = ActiveSheet.Shapes(CurWnd.RangeFromPoint(.x, .y).Name)
If Not Shp Is Nothing Then
This.ToolTipProvider.HideToolTip
End If
End With
End If
End If
End If
End Sub
Public Sub StartTicking(ByVal argToolTipProvider As CRangeToolTip, ByVal argWndTitle As String)
Set This.ToolTipProvider = argToolTipProvider
This.xlWndTitle = argWndTitle
SetTimer Application.hwnd, 1, CUSTOMIZEDINTERVAL, AddressOf TickTock
End Sub
Public Sub StopTicking()
KillTimer Application.hwnd, 1
Set This.ToolTipProvider = Nothing
End Sub
Private Function PointOnScreen(ByVal argObject As Object, Optional ByVal argPos As RelativePosition = TopLeft) As POINTAPI
' Converts Points to Screen Pixels
Dim ZoomPerc As Double, CurWin As Excel.Window
Set CurWin = Excel.Application.ActiveWindow
ZoomPerc = CurWin.Zoom / 100
With This
.hDC = GetDC(0)
.PixelsPerPointX = GetDeviceCaps(.hDC, LOGPIXELSX) / POINTSPERINCH
.PointsPerPixelX = POINTSPERINCH / GetDeviceCaps(.hDC, LOGPIXELSX)
.PixelsPerPointY = GetDeviceCaps(.hDC, LOGPIXELSY) / POINTSPERINCH
.PointsPerPixelY = POINTSPERINCH / GetDeviceCaps(.hDC, LOGPIXELSY)
Select Case argPos
Case TopLeft
PointOnScreen.x = CurWin.PointsToScreenPixelsX(argObject.Left * (.PixelsPerPointX * ZoomPerc)) * .PointsPerPixelX
PointOnScreen.y = CurWin.PointsToScreenPixelsY(argObject.Top * (.PixelsPerPointY * ZoomPerc)) * .PointsPerPixelY
Case TopRight
PointOnScreen.x = CurWin.PointsToScreenPixelsX((argObject.Left + argObject.Width) * (.PixelsPerPointX * ZoomPerc)) * .PointsPerPixelX
PointOnScreen.y = CurWin.PointsToScreenPixelsY(argObject.Top * (.PixelsPerPointY * ZoomPerc)) * .PointsPerPixelY
Case BottomLeft
PointOnScreen.x = CurWin.PointsToScreenPixelsX(argObject.Left * (.PixelsPerPointX * ZoomPerc)) * .PointsPerPixelX
PointOnScreen.y = CurWin.PointsToScreenPixelsY((argObject.Top + argObject.Height) * (.PixelsPerPointY * ZoomPerc)) * .PointsPerPixelY
Case BottomRight
PointOnScreen.x = CurWin.PointsToScreenPixelsX((argObject.Left + argObject.Width) * (.PixelsPerPointX * ZoomPerc)) * .PointsPerPixelX
PointOnScreen.y = CurWin.PointsToScreenPixelsY((argObject.Top + argObject.Height) * (.PixelsPerPointY * ZoomPerc)) * .PointsPerPixelY
End Select
ReleaseDC 0, .hDC
End With
End Function
Public Property Let MonitorClosePrompt(ByVal BeforeCloseCancelArgument As Boolean, ByVal Monitor As Boolean)
If ThisWorkbook.Saved Then Exit Property
If BeforeCloseCancelArgument And Monitor Then Exit Property
If Monitor Then
If hHook <> 0 Then Exit Property
hHook = SetWindowsHookEx(WH_CBT, AddressOf CBT_Func, 0, GetCurrentThreadId())
Else
If hHook = 0 Then Exit Property
Call UnhookWindowsHookEx(hHook)
hHook = 0
End If
End Property
Private Function CBT_Func(ByVal ncode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Dim IID As GUID
Dim oAccObj As IAccessible
Dim vCancelBtn As Variant
Dim sBuffer As String * 255
Dim i As Long
On Error Resume Next
If ncode = HCBT_DESTROYWND Then
If GetClassName(wParam, sBuffer, Len(sBuffer)) <> 0 Then
If Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1) = "NUIDialog" Then
MonitorClosePrompt(BeforeCloseCancelArgument:=False) = False
Call IIDFromString(StrPtr(IID_IAccessible), IID)
If AccessibleObjectFromWindow(wParam, OBJID_CLIENT, IID, oAccObj) = S_OK Then
If AccessibleChildren(oAccObj, 0, 1, vCancelBtn, 1) = S_OK Then
Set vCancelBtn = vCancelBtn.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
Set vCancelBtn = vCancelBtn.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
For i = 1 To 10
Set vCancelBtn = vCancelBtn.accNavigate(NAVDIR_NEXT, CHILDID_SELF)
If i = 10 And Not IsEmpty(vCancelBtn.accFocus) Then
Debug.Print "You Clicked CANCEL"
SetTimer Application.hwnd, 0, 0, AddressOf BeforeCloseOnCancel
GoTo NxtHook
End If
Next i
End If
End If
End If
End If
End If
NxtHook:
CBT_Func = CallNextHookEx(hHook, ncode, wParam, lParam)
End Function
Private Sub BeforeCloseOnCancel()
On Error Resume Next
KillTimer Application.hwnd, 0
On Error GoTo 0
'MsgBox "CANCEL button clicked !" & vbLf & vbLf & _
'"Running vba code after cancelling the closing of the workbook is now possible."
SheetOnFocus Excel.Application.ActiveSheet
End Sub
Public Sub SheetOnFocus(ByVal argSht As Object)
Select Case argSht.CodeName
Case "Sheet1"
With This
Set .ToolTipProvider = New CRangeToolTip
.ToolTipProvider.Initialize argWndTitle:=Excel.Application.ActiveWindow.Caption, argSht:=argSht, argRng:=argSht.Range("C2,C6:E10")
'.ToolTipProvider.AddRange argSht.Range("C6:E10")
End With
Case "Sheet2"
With This
Set .ToolTipProvider = New CRangeToolTip
.ToolTipProvider.Initialize argWndTitle:=Excel.Application.ActiveWindow.Caption, argSht:=argSht, argRng:=argSht.Range("Table1")
End With
End Select
End Sub
Public Sub SheetOnExit()
With This
If Not .ToolTipProvider Is Nothing Then
.ToolTipProvider.Terminate
Set .ToolTipProvider = Nothing
End If
End With
End Sub
'Callback for Backstage.onShow
Public Sub BackstageOnShow(contextObject As Object)
If Excel.Application.ActiveWorkbook.FullName = ThisWorkbook.FullName Then
SheetOnExit
End If
End Sub
'Callback for Backstage.onHide
Public Sub BackstageOnHide(contextObject As Object)
If Excel.Application.ActiveWorkbook.FullName = ThisWorkbook.FullName Then
SheetOnFocus Excel.Application.ActiveSheet
End If
End Sub
