Option Explicit
'This code requires adding a VBE reference to the UIAutomationClient library (UIAutomationCore.dll)
#If Win64 Then
Private Const NULL_PTR = 0^
#Else
Private Const NULL_PTR = 0&
#End If
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
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 Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
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 SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
Private Declare PtrSafe Function SendInput Lib "USER32.DLL" (ByVal cInputs As Long, pInputs As Any, ByVal cbSize As Integer) As Long
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As LongPtr, ByVal dwId As Long, ByVal riid As LongPtr, ppvObject As Any) As Long
Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
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
#Else
Private Enum LongPtr
[_]
End Enum
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare 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 Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
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 SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
Private Declare Function SendInput Lib "USER32.DLL" (ByVal cInputs As Long, pInputs As Any, ByVal cbSize As Integer) As Long
Private Declare Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As LongPtr, ByVal dwId As Long, ByVal riid As LongPtr, ppvObject As Any) As Long
Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
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
#End If
Private Enum STATUSBAR_DISPLAY_CHECKED
Unchecked = 1048576
Checked = 1048592
End Enum
Private Type LongToInteger
Low As Integer
High As Integer
End Type
Private Type KEYBDINPUT
wVk As Integer
wScan As Integer
dwFlags As Long
time As Long
dwExtraInfo As LongPtr
padding As Currency
End Type
Private Type tagINPUT
INPUTTYPE As Long
ki As KEYBDINPUT
End Type
Public oDictCurEntries As Object, oDictUpdatedEntries As Object
Private bUpdate As Boolean
Public Sub AutomateStatusBar(ByVal Update As Boolean)
Const WH_CBT = 5&, WM_MOUSEMOVE = &H200, WM_RBUTTONDOWN = &H204, WM_RBUTTONUP = &H205
Dim hwnd As LongPtr, lHook As LongPtr, lp As Long
On Error GoTo errHandler
If oDictCurEntries Is Nothing Then
Set oDictCurEntries = CreateObject("Scripting.Dictionary")
Set oDictUpdatedEntries = CreateObject("Scripting.Dictionary")
End If
bUpdate = Update
Call UnhookWindowsHookEx(GetProp(Application.hwnd, "Hook"))
lHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, NULL_PTR, GetCurrentThreadId)
Call SetProp(Application.hwnd, "Hook", lHook)
If Not Application.CommandBars("Status Bar").Visible Then
Application.CommandBars("Status Bar").Visible = True
End If
hwnd = FindWindowEx(Application.hwnd, NULL_PTR, "EXCEL2", vbNullString)
hwnd = FindWindowEx(hwnd, NULL_PTR, "MsoCommandBar", "Status Bar")
Call SetTopMost(Application.hwnd, True)
lp = MAKELPARAM(1, 1)
Call SendMessage(hwnd, WM_MOUSEMOVE, NULL_PTR, ByVal lp)
Call SendMessage(hwnd, WM_RBUTTONDOWN, NULL_PTR, ByVal lp)
Call SendMessage(hwnd, WM_RBUTTONUP, NULL_PTR, ByVal lp)
errHandler:
Call UnhookWindowsHookEx(GetProp(Application.hwnd, "Hook"))
Call SetTopMost(Application.hwnd, False)
bUpdate = False
End Sub
' __________________________________ PRIVATE HELPER ROUTINES _______________________________________
Private Function HookProc( _
ByVal idHook As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr _
) As LongPtr
Const HCBT_ACTIVATE = 5&
Dim sBuff As String * 256&, lRet As Long
Dim oAccSBarContextMenu As IAccessible, vAcc As Variant
On Error Resume Next
If idHook = HCBT_ACTIVATE Then
lRet = GetClassName(wParam, sBuff, 256&)
If Left(sBuff, lRet) = "Net UI Tool Window" Then
Call UnhookWindowsHookEx(GetProp(Application.hwnd, "Hook"))
Set oAccSBarContextMenu = HwndToAcc(wParam)
Call AccessibleChildren(oAccSBarContextMenu, 3&, 1&, vAcc, 1&)
Call ShowWindow(wParam, 0&)
Call PressAltKey
Call SearchAccChildren(vAcc)
End If
End If
HookProc = CallNextHookEx(GetProp(Application.hwnd, "Hook"), idHook, ByVal wParam, ByVal lParam)
End Function
Private Sub SearchAccChildren(ByVal Acc As Variant)
Dim oCUI As New CUIAutomation
Dim oParentElement As IUIAutomationElement
Dim oCondition As IUIAutomationCondition
Dim oElement As IUIAutomationElement
Dim oAllElementArray As IUIAutomationElementArray
Dim i As Long, lNextDisplay As Long
Set oParentElement = oCUI.ElementFromIAccessible(Acc, 0&)
Set oCondition = oCUI.CreateTrueCondition
Set oAllElementArray = oParentElement.FindAll(TreeScope_Children, oCondition)
For i = 0& To oAllElementArray.Length - 1&
Set oElement = oAllElementArray.GetElement(i)
Call RecurseElements(oCUI, oElement, 0&, lNextDisplay)
Next
End Sub
Private Sub RecurseElements( _
ByVal oCUI As CUIAutomation, _
ByVal oElement As IUIAutomationElement, _
ByVal Level As Long, _
ByRef NextDisplay As Long _
)
Dim oCondition As IUIAutomationCondition
Dim oAllElementArray As IUIAutomationElementArray
Dim oSubElement As IUIAutomationElement
Dim oIAccessiblePattern As IUIAutomationLegacyIAccessiblePattern
Dim oInvokePattern As IUIAutomationInvokePattern
Dim oAccessible As IAccessible
Dim lCurState As STATUSBAR_DISPLAY_CHECKED
Dim bEnabled As Boolean, bUpdatedState As Boolean
Dim i As Long
Set oCondition = oCUI.CreateTrueCondition
Set oAllElementArray = oElement.FindAll(TreeScope_Children, oCondition)
For i = 0& To oAllElementArray.Length - 1&
Set oSubElement = oAllElementArray.GetElement(i)
If oElement.CurrentControlType = 50011 Then
Set oIAccessiblePattern = oElement.GetCurrentPattern(UIA_LegacyIAccessiblePatternId)
Set oAccessible = oIAccessiblePattern.GetIAccessible
lCurState = oAccessible.accState(0&)
On Error Resume Next
oDictCurEntries.Add oElement.CurrentName, IIf(lCurState = Checked, True, False)
On Error GoTo 0
If bUpdate Then
bUpdatedState = oDictUpdatedEntries.Items()(NextDisplay)
Set oInvokePattern = oElement.GetCurrentPattern(UIA_InvokePatternId)
Select Case lCurState
Case Is = Checked
If bUpdatedState = False Then
oInvokePattern.Invoke
End If
Case Is = Unchecked
If bUpdatedState = True Then
oInvokePattern.Invoke
End If
End Select
End If
NextDisplay = NextDisplay + 1&
Level = Level + 1&
End If
Call RecurseElements(oCUI, oSubElement, Level, NextDisplay)
Next
End Sub
Private Function HwndToAcc(ByVal hwnd As LongPtr) As IAccessible
Const ID_ACCESSIBLE As String = "{618736E0-3C3D-11CF-810C-00AA00389B71}"
Const OBJID_WINDOW = 0&, S_OK = &H0&
Dim tGUID(0& To 3&) As Long
Dim oIAc As IAccessible
hwnd = GetNextWindow(hwnd, 5&)
If IIDFromString(StrPtr(ID_ACCESSIBLE), VarPtr(tGUID(0&))) = S_OK Then
If AccessibleObjectFromWindow(hwnd, OBJID_WINDOW, VarPtr(tGUID(0&)), oIAc) = S_OK Then
Set HwndToAcc = oIAc
End If
End If
End Function
Private Sub PressAltKey()
Const KEYEVENTF_KEYUP = &H2, KEYEVENTF_UNICODE = &H4, VK_MENU = &H12
ReDim InputArray(2&) As tagINPUT
InputArray(0&).INPUTTYPE = 1&
InputArray(0&).ki.wVk = VK_MENU
InputArray(0&).ki.dwFlags = KEYEVENTF_UNICODE
InputArray(1&).INPUTTYPE = 1&
InputArray(1&).ki.wVk = VK_MENU
InputArray(1&).ki.dwFlags = KEYEVENTF_UNICODE + KEYEVENTF_KEYUP
Call SendInput(2&, InputArray(0&), LenB(InputArray(0&)))
End Sub
Private Sub SetTopMost(ByVal hwnd As LongPtr, ByVal bTopMost As Boolean)
Const HWND_TOPMOST = -1, HWND_NOTOPMOST = -2, SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2, SWP_SHOWWINDOW = &H40, SWP_ASYNCWINDOWPOS = &H4000
DoEvents
Call SetWindowPos(Application.hwnd, IIf(bTopMost, HWND_TOPMOST, HWND_NOTOPMOST), 0&, 0&, 0&, 0&, _
SWP_ASYNCWINDOWPOS + SWP_NOSIZE + SWP_SHOWWINDOW + SWP_NOMOVE)
End Sub
Private Function MAKELONG(wLow As Integer, wHigh As Integer) As Long
MAKELONG = loword(wLow) Or (&H10000 * loword(wHigh))
End Function
Private Function MAKELPARAM(wLow As Integer, wHigh As Integer) As Long
MAKELPARAM = MAKELONG(wLow, wHigh)
End Function
Private Function loword(ByVal Word As Long) As Integer
Dim x As LongToInteger
Call CopyMemory(x, Word, LenB(x))
loword = x.Low
End Function
Private Function hiword(ByVal Word As Long) As Integer
Dim x As LongToInteger
Call CopyMemory(x, Word, LenB(x))
hiword = x.High
End Function