Option Explicit
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
#If VBA7 Then
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 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 CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal pModuleName As LongPtr) As LongPtr
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 AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As Long, ByVal dwId As Long, ByVal riid As Long, ppvObject As Any) As Long
Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByVal lpiid As Long) 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 CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal pModuleName As Long) 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 sFuncsArray() As String
Private bFilterOut As Boolean
Public Function GetAllExcelFunctions(Optional ByVal ExcludeVBProjectFunctions As Boolean) As String()
Const WH_CBT = 5
If hHook Then Exit Function
Application.EnableCancelKey = xlDisabled
bFilterOut = ExcludeVBProjectFunctions
hHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, GetModuleHandle(StrPtr(vbNullString)), GetCurrentThreadId)
Application.Dialogs(xlDialogFunctionWizard).Show
GetAllExcelFunctions = sFuncsArray
ReDim sFuncsArray(UBound(sFuncsArray))
Call UnhookWindowsHookEx(hHook): hHook = 0
End Function
'_______________________________________PRIVATE ROUTINES______________________________________________
#If Win64 Then
Private Function HookProc(ByVal lCode As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
#Else
Private Function HookProc(ByVal lCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
Const HC_ACTION = 0
Const HCBT_ACTIVATE = 5
If lCode < HC_ACTION Then
HookProc = CallNextHookEx(hHook, lCode, wParam, lParam)
Exit Function
End If
If lCode = HCBT_ACTIVATE Then
If IsDlg(wParam) Then
Call UnhookWindowsHookEx(hHook): hHook = 0
Call GetTheFunctions(wParam)
End If
End If
Call CallNextHookEx(hHook, lCode, wParam, lParam)
End Function
#If Win64 Then
Private Sub GetTheFunctions(ByVal hwnd As LongLong)
#Else
Private Sub GetTheFunctions(ByVal hwnd As Long)
#End If
Const ID_ACCESSIBLE As String = "{618736E0-3C3D-11CF-810C-00AA00389B71}"
Const ROLE_SYSTEM_COMBOBOX = &H2E
Const ROLE_SYSTEM_LIST = &H21
Const OBJID_CLIENT = &HFFFFFFFC
Const S_OK = &H0&
Dim tGUID(0 To 3) As Long
Dim sUserDefinedArray() As String
Dim oAccClient As IAccessible, oAccChild As IAccessible
Dim oAccUserDefined As IAccessible, oAccUserDefinedList As IAccessible
Dim lClientChildIndex1 As Long, lClientChildIndex2 As Long
Dim lUserDefinedListIndex As Long, lClientChildCount As Long, lFuncIndex As Long
Dim i As Long, j As Long
On Error Resume Next
If IIDFromString(StrPtr(ID_ACCESSIBLE), VarPtr(tGUID(0))) = S_OK Then
If AccessibleObjectFromWindow(hwnd, OBJID_CLIENT, VarPtr(tGUID(0)), oAccClient) = S_OK Then
If bFilterOut Then
Do
If oAccClient.accRole(i) = ROLE_SYSTEM_COMBOBOX Then
lClientChildCount = oAccClient.accChildCount
For lClientChildIndex1 = 0 To lClientChildCount
Set oAccUserDefined = oAccClient.accChild(i)
If oAccUserDefined.accName(lClientChildIndex1) = "User Defined" Then
oAccUserDefined.accDoDefaultAction (lClientChildIndex1)
For lClientChildIndex2 = 0 To lClientChildCount
If oAccClient.accRole(lClientChildIndex2) = ROLE_SYSTEM_LIST Then
Set oAccUserDefinedList = oAccClient.accChild(lClientChildIndex2)
For lUserDefinedListIndex = 0 To oAccUserDefinedList.accChildCount
ReDim Preserve sUserDefinedArray(lUserDefinedListIndex)
sUserDefinedArray(lUserDefinedListIndex) = oAccUserDefinedList.accName(lUserDefinedListIndex)
Next lUserDefinedListIndex
End If
Next lClientChildIndex2
End If
Next lClientChildIndex1
End If
i = i + 1
lClientChildCount = oAccClient.accChildCount
DoEvents
Loop Until i >= lClientChildCount
End If
i = 0
Do
If oAccClient.accRole(i) = ROLE_SYSTEM_COMBOBOX Then
oAccClient.accChild(i).accDoDefaultAction (2&)
End If
If oAccClient.accRole(i) = ROLE_SYSTEM_LIST Then
For j = 1 To oAccClient.accChild(i).accChildCount
Set oAccChild = oAccClient.accChild(i)
If IsValueInArray(oAccChild.accName(j), sUserDefinedArray) = False Then
ReDim Preserve sFuncsArray(lFuncIndex + 1)
sFuncsArray(lFuncIndex) = oAccChild.accName(j)
lFuncIndex = lFuncIndex + 1
End If
Next j
End If
i = i + 1
DoEvents
Loop Until i >= oAccClient.accChildCount
oAccClient.accDoDefaultAction (13&)
End If
End If
End Sub
#If Win64 Then
Private Function IsDlg(ByVal hwnd As LongLong) As Boolean
#Else
Private Function IsDlg(ByVal hwnd As Long) As Boolean
#End If
Const MAX_PATH = 260
Dim sClassName As String * MAX_PATH, lRet As Long
lRet = GetClassName(hwnd, sClassName, MAX_PATH)
If Left$(sClassName, lRet) = "bosa_sdm_XL9" Then IsDlg = True
End Function
Private Function IsValueInArray(vValue As Variant, Arr As Variant) As Boolean
On Error Resume Next
If IsArray(Arr) Then
IsValueInArray = InStr(1, vbNullChar & Join(Arr, vbNullChar) & vbNullChar, vbNullChar & vValue & vbNullChar)
End If
End Function