Custom Accessibility Class

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,656
Office Version
  1. 2016
Platform
  1. Windows
Hi all,

I have been working on this little project for the last couple of days and thought I would post it here for the benefit of others.

In some situations, we find ourselves in need to retrieve info about automation elements for a specific window. The easiest way is to use the UIAutomationClient library and call the ElementFromHandle Method but, in order to use this library, we first need to set a vbaproject reference to it @ design time. I hate having to reference external libraries in my workbooks, plus the fact that the UIAutomationClient is somewhat overwhelmingly complicated made me think of trying to write this easier class for the required task.

Obviously, we could always simply use the IAccessibility Interface for walking the accessibility tree but, unlike the Automation library, it lacks many useful and interesting Properties and Methods. The class I am posting here uses low level com calls (no external references required) and indirectly borrows Properties and Methods from both interfaces: IAccessibility and IUIAutomation.

I have tested the class in both excel x32 and x64. So far, it works as expected. I just hope it is robust enough.


File Download:
AccessibilityEx.xlsm



1- Class code: (C_AccEx)
VBA Code:
Option Explicit

Implements IAccElement

#If Win64 Then
    Private Const NULL_PTR = 0^
    Private Const PTR_LEN = 8&
#Else
    Private Const NULL_PTR = 0&
    Private Const PTR_LEN = 4&
#End If

Public Enum TreeScope
    TreeScope_None = 0&
    TreeScope_Element = 1&
    TreeScope_Children = 2&
    TreeScope_Descendants = 4&
    TreeScope_Subtree = ((TreeScope_Element + TreeScope_Children) + TreeScope_Descendants)
End Enum

#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 lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
    Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
    Private Declare PtrSafe Function StringFromGUID2 Lib "ole32" (ByRef rguid As GUID, ByVal lpsz As LongPtr, ByVal cchMax As Long) As Long
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As GUID) As Long
    Private Declare PtrSafe Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) 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 IsWindow Lib "user32" (ByVal hwnd As LongPtr) 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 lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
    Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
    Private Declare Function StringFromGUID2 Lib "ole32" (ByRef rguid As GUID, ByVal lpsz As LongPtr, ByVal cchMax As Long) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As GUID) As Long
    Private Declare Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) 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 IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
#End If

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type RECT_PTR
    Left As LongPtr
    Top As LongPtr
    Right As LongPtr
    Bottom As LongPtr
End Type

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0& To 7&) As Byte
End Type

Private oElements As Collection
Private oElement  As C_AccEx

Private pAutomation As LongPtr
Private pPattern As LongPtr
Private pElement As LongPtr
Private pElementArray As LongPtr
Private pTrueCond As LongPtr

Private pLegacyName As LongPtr
Private pAccKey As LongPtr
Private pItemType As LongPtr
Private pLocalControlType As LongPtr
Private pDefaultAction As LongPtr
Private pKeyboardShortcut As LongPtr
Private pClassName As LongPtr
Private pValue As LongPtr
Private pLegacyDescription As LongPtr
Private pLegacyHelp As LongPtr
Private lHwnd As LongPtr

Private lOrientation As Long
Private lItemStatus As Long
Private lProcID As Long
Private lRole As Long
Private lState As Long
Private lControlType As Long
Private lProcessID As Long

Private sName As String
Private sDescription As String
Private sHelpText As String
Private sValue As String
Private sDefaultAction As String
Private sKeyboardShortcut As String
Private sAcceleratorKey As String
Private sClassName As String
Private sItemType As String
Private sLocalControlType As String

Private bHasKeyboardFocus As Boolean
Private bIsEnabled As Boolean
Private bOffScreen As Boolean
Private bIsPassword As Boolean


Private Sub Class_Initialize()
    Set oElements = New Collection
End Sub

' __________________________________________ Public Members __________________________________________________

Sub GetAccessibleChildrenFromHwnd(ByVal hwnd As LongPtr, Optional ByVal Scope As TreeScope = TreeScope_Subtree)
    If IsWindow(hwnd) = 0& Then
        MsgBox "Invalid Window Handle !":    Exit Sub
    End If
    Call FindElements(hwnd, Scope)
End Sub

Function ElementsCount() As Long
    ElementsCount = oElements.Count
End Function

Property Get Items() As Collection
    Set Items = oElements
End Property


Property Get Name() As String
    Name = sName
End Property
Property Let Name(ByVal vNewValue As String)
    sName = vNewValue
End Property

Property Get Role() As Long
    Role = lRole
End Property
Property Let Role(ByVal vNewValue As Long)
    lRole = vNewValue
End Property

Property Get Description() As String
    Description = sDescription
End Property
Property Let Description(ByVal vNewValue As String)
    sDescription = vNewValue
End Property

Property Get HelpText() As String
    HelpText = sHelpText
End Property
Property Let HelpText(ByVal vNewValue As String)
    sHelpText = vNewValue
End Property

Property Get State() As Long
    State = lState
End Property
Property Let State(ByVal vNewValue As Long)
    lState = vNewValue
End Property

Property Get Value() As String
    Value = sValue
End Property
Property Let Value(ByVal vNewValue As String)
    sValue = vNewValue
End Property

Property Get DefaultAction() As String
    DefaultAction = sDefaultAction
End Property
Property Let DefaultAction(ByVal vNewValue As String)
    sDefaultAction = vNewValue
End Property

Property Get KeyboardShortcut() As String
    KeyboardShortcut = sKeyboardShortcut
End Property
Property Let KeyboardShortcut(ByVal vNewValue As String)
    sKeyboardShortcut = vNewValue
End Property

Property Get AcceleratorKey() As String
    AcceleratorKey = sAcceleratorKey
End Property
Property Let AcceleratorKey(ByVal vNewValue As String)
    sAcceleratorKey = vNewValue
End Property

Property Get ControlType() As Long
    ControlType = lControlType
End Property
Property Let ControlType(ByVal vNewValue As Long)
    lControlType = vNewValue
End Property

Property Get HasKeyboardFocus() As Boolean
    HasKeyboardFocus = bHasKeyboardFocus
End Property
Property Let HasKeyboardFocus(ByVal vNewValue As Boolean)
    bHasKeyboardFocus = vNewValue
End Property

Property Get IsEnabled() As Boolean
    IsEnabled = bIsEnabled
End Property
Property Let IsEnabled(ByVal vNewValue As Boolean)
    bIsEnabled = vNewValue
End Property

Property Get ClassName() As String
    ClassName = sClassName
End Property
Property Let ClassName(ByVal vNewValue As String)
    sClassName = vNewValue
End Property

Property Get IsOffScreen() As Boolean
    IsOffScreen = bOffScreen
End Property
Property Let IsOffScreen(ByVal vNewValue As Boolean)
    bOffScreen = vNewValue
End Property

Property Get ItemType() As String
   ItemType = sItemType
End Property
Property Let ItemType(ByVal vNewValue As String)
    sItemType = vNewValue
End Property

Property Get ProcessID() As Long
    ProcessID = lProcessID
End Property
Property Let ProcessID(ByVal vNewValue As Long)
    lProcessID = vNewValue
End Property

Property Get LocalControlType() As String
    LocalControlType = sLocalControlType
End Property
Property Let LocalControlType(ByVal vNewValue As String)
    sLocalControlType = vNewValue
End Property

Property Get Orientation() As Long
    Orientation = lOrientation
End Property
Property Let Orientation(ByVal vNewValue As Long)
    lOrientation = vNewValue
End Property

Property Get ItemStatus() As Long
    ItemStatus = lItemStatus
End Property
Property Let ItemStatus(ByVal vNewValue As Long)
    lItemStatus = vNewValue
End Property

Property Get IsPassword() As Boolean
    IsPassword = bIsPassword
End Property
Property Let IsPassword(ByVal vNewValue As Boolean)
    bIsPassword = vNewValue
End Property

Property Get WindowHandle() As LongPtr
    WindowHandle = lHwnd
End Property
Property Let WindowHandle(ByVal vNewValue As LongPtr)
    lHwnd = vNewValue
End Property

Property Get pIAutomation() As LongPtr
    pIAutomation = pAutomation
End Property
Property Let pIAutomation(ByVal vNewValue As LongPtr)
    pAutomation = vNewValue
End Property

Property Get pIPattern() As LongPtr
    pIPattern = pPattern
End Property
Property Let pIPattern(ByVal vNewValue As LongPtr)
    pPattern = vNewValue
End Property

Property Get pITrueCond() As LongPtr
    pITrueCond = pTrueCond
End Property
Property Let pITrueCond(ByVal vNewValue As LongPtr)
    pTrueCond = vNewValue
End Property

Property Get pIElementArray() As LongPtr
    pIElementArray = pElementArray
End Property
Property Let pIElementArray(ByVal vNewValue As LongPtr)
    pElementArray = vNewValue
End Property

Property Get pIElement() As LongPtr
    pIElement = pElement
End Property
Property Let pIElement(ByVal vNewValue As LongPtr)
    pElement = vNewValue
End Property

Sub GetClickablePoint(ByRef X As Long, ByRef Y As Long)
    Call ClickablePoint(X, Y)
End Sub

Sub GetScreenBoundingRectangle(X As Long, Y As Long, nWidth As Long, nHeight As Long)
    Call ScreenBoundingRectangle(X, Y, nWidth, nHeight)
End Sub

Sub SelectMe()
    Call Select_Item
End Sub

Sub DoDefaultAction()
    Call DoDefaultAct
End Sub



' _____________________________________________ Interface Imp Routines ___________________________________________

Private Property Get IAccElement_pIAutomation() As LongPtr
    IAccElement_pIAutomation = pAutomation
End Property

Private Property Get IAccElement_pITrueCond() As LongPtr
    IAccElement_pITrueCond = pTrueCond
End Property

Private Property Get IAccElement_pIElementArray() As LongPtr
    IAccElement_pIElementArray = pElementArray
End Property

Private Property Get IAccElement_pIElement() As LongPtr
    IAccElement_pIElement = pElement
End Property

Private Property Get IAccElement_pIPattern() As LongPtr
    IAccElement_pIPattern = pPattern
End Property


Private Property Get IAccElement_DefaultAction() As String
    IAccElement_DefaultAction = sDefaultAction
End Property

Private Property Get IAccElement_Description() As String
    IAccElement_Description = sDescription
End Property

Private Property Get IAccElement_AcceleratorKey() As String
    IAccElement_AcceleratorKey = sAcceleratorKey
End Property

Private Property Get IAccElement_HelpText() As String
    IAccElement_HelpText = sHelpText
End Property

Private Property Get IAccElement_KeyboardShortcut() As String
    IAccElement_KeyboardShortcut = sKeyboardShortcut
End Property

Private Property Get IAccElement_Name() As String
    IAccElement_Name = sName
End Property

Private Property Get IAccElement_Role() As Long
    IAccElement_Role = lRole
End Property

Private Property Get IAccElement_State() As Long
    IAccElement_State = lState
End Property

Private Property Get IAccElement_Value() As String
    IAccElement_Value = sValue
End Property

Private Property Get IAccElement_ClassName() As String
    IAccElement_ClassName = sClassName
End Property

Private Property Get IAccElement_ControlType() As Long
    IAccElement_ControlType = lControlType
End Property

Private Property Get IAccElement_HasKeyboardFocus() As Boolean
    IAccElement_HasKeyboardFocus = bHasKeyboardFocus
End Property

Private Property Get IAccElement_IsEnabled() As Boolean
    IAccElement_IsEnabled = bIsEnabled
End Property

Private Property Get IAccElement_IsOffScreen() As Boolean
    IAccElement_IsOffScreen = bOffScreen
End Property

Private Property Get IAccElement_IsPassword() As Boolean
    IAccElement_IsPassword = bIsPassword
End Property

Private Property Get IAccElement_ItemStatus() As Long
    IAccElement_ItemStatus = lItemStatus
End Property

Private Property Get IAccElement_ItemType() As String
    IAccElement_ItemType = sItemType
End Property

Private Property Get IAccElement_LocalControlType() As String
    IAccElement_LocalControlType = sLocalControlType
End Property

Private Property Get IAccElement_Orientation() As String
    IAccElement_Orientation = lOrientation
End Property

Private Property Get IAccElement_ProcessID() As Long
    IAccElement_ProcessID = lProcessID
End Property

Private Property Get IAccElement_WindowHandle() As LongPtr
    IAccElement_WindowHandle = lHwnd
End Property


Private Sub IAccElement_SelectMe()
    Call Select_Item
End Sub

Private Sub IAccElement_DoDefaultAction()
    Call DoDefaultAct
End Sub

Private Sub IAccElement_GetClickablePoint(ByRef X As Long, ByRef Y As Long)
    Call ClickablePoint(X, Y)
End Sub

Private Sub IAccElement_GetScreenBoundingRectangle(ByRef X As Long, ByRef Y As Long, ByRef nWidth As Long, ByRef nHeight As Long)
    Call ScreenBoundingRectangle(X, Y, nWidth, nHeight)
End Sub


' ___________________________________________ Private Routines __________________________________________________

Private Function GetAutomationPtr() As LongPtr

    Const IID_CUIAUTOMATION = "{FF48DBA4-60EF-4201-AA87-54103EEF594E}"
    Const IID_IUIAUTOMATION = "{30CBE57D-D9D0-452A-AB13-7AC5AC4825EE}"
    Const CLSCTX_INPROC_SERVER = &H1, CC_STDCALL = 4&, S_OK = 0&
 
    Dim iidCuiAuto As GUID, iidIuiAuto As GUID, lRet As Long
 
    lRet = CLSIDFromString(StrPtr(IID_CUIAUTOMATION), iidCuiAuto)
    Call DispGUID(iidCuiAuto)
    lRet = CLSIDFromString(StrPtr(IID_IUIAUTOMATION), iidIuiAuto)
    Call DispGUID(iidIuiAuto)
    lRet = CoCreateInstance(iidCuiAuto, NULL_PTR, CLSCTX_INPROC_SERVER, iidIuiAuto, pAutomation)
 
    If lRet = S_OK Then GetAutomationPtr = pAutomation

End Function

Private Sub FindElements(ByVal hwnd As LongPtr, Optional ByVal Scope As TreeScope = TreeScope_Subtree)

    Const CC_STDCALL = 4&, TreeScope_Descendants = 4&, UIA_LegacyIAccessiblePatternId = 10018&
    Const IID_IUIAutomationLegacyIAccessiblePattern = "{828055ad-355b-4435-86d5-3b51c14a9b1b}"
    Dim lIndex As Long, lElementsCount As Long
    Dim lRet As Long, vTblOffset As Long, vFuncOrdinal As Long
    Dim iidCuiAuto As GUID


    pAutomation = GetAutomationPtr
    If pAutomation = NULL_PTR Then MsgBox "Automation failed.": Exit Sub
 
    vFuncOrdinal = 6& ' IUIAutomation::ElementFromHandle
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblCall(pAutomation, vTblOffset, vbLong, CC_STDCALL, hwnd, VarPtr(pElement))
 
    vFuncOrdinal = 21& ' IUIAutomation::CreateTrueCondition
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblCall(pAutomation, vTblOffset, vbLong, CC_STDCALL, VarPtr(pTrueCond))
 
    vFuncOrdinal = 6& ' IUIAutomationElement::FindAll
    vTblOffset = vFuncOrdinal * PTR_LEN ' IUIAutomationElement::FindAll
    lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, Scope, pTrueCond, VarPtr(pElementArray))

    vFuncOrdinal = 3& ' IUIAutomationElementArray :get_Length
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblCall(pElementArray, vTblOffset, vbLong, CC_STDCALL, VarPtr(lElementsCount))

    If lElementsCount = 0& Then
        MsgBox "No Accessible descendants were found.": Exit Sub
    End If
 
    For lIndex = 0& To lElementsCount - 1&
 
        vFuncOrdinal = 4& ' IUIAutomationElementArray :GetElement
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblCall(pElementArray, vTblOffset, vbLong, CC_STDCALL, lIndex, VarPtr(pElement))
     
        lRet = CLSIDFromString(StrPtr(IID_IUIAutomationLegacyIAccessiblePattern), iidCuiAuto)
        Call DispGUID(iidCuiAuto)
        vFuncOrdinal = 14& 'IID_IUIAutomationElement::GetCurrentPatternAs
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, UIA_LegacyIAccessiblePatternId, VarPtr(iidCuiAuto), VarPtr(pPattern))
   
        If pPattern <> NULL_PTR Then
         
            'Store Interfaces Ptrs in each new class instance.
            Set oElement = New C_AccEx
            With oElement
                .pIAutomation = pAutomation
                .pITrueCond = pTrueCond
                .pIElementArray = pElementArray
                .pIElement = pElement
                .pIPattern = pPattern
            End With
         
            'Retrieve descendants properties.
            vFuncOrdinal = 7& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentName
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pPattern, vTblOffset, vbLong, CC_STDCALL, VarPtr(pLegacyName))
            oElement.Name = GetStrFromPtrW(pLegacyName)
         
            vFuncOrdinal = 10& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentRole
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pPattern, vTblOffset, vbLong, CC_STDCALL, VarPtr(lRole))
            oElement.Role = lRole
         
            vFuncOrdinal = 9& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentDescription
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pPattern, vTblOffset, vbLong, CC_STDCALL, VarPtr(pLegacyDescription))
            oElement.Description = GetStrFromPtrW(pLegacyDescription)
         
            vFuncOrdinal = 12& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentHelp
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pPattern, vTblOffset, vbLong, CC_STDCALL, VarPtr(pLegacyHelp))
            oElement.HelpText = GetStrFromPtrW(pLegacyHelp)
         
            vFuncOrdinal = 11& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentState
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pPattern, vTblOffset, vbLong, CC_STDCALL, VarPtr(lState))
            oElement.State = lState
         
            vFuncOrdinal = 8& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentValue
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pPattern, vTblOffset, vbLong, CC_STDCALL, VarPtr(pValue))
            oElement.Value = GetStrFromPtrW(pValue)
         
            vFuncOrdinal = 15& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentDefaultAction
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pPattern, vTblOffset, vbLong, CC_STDCALL, VarPtr(pDefaultAction))
            oElement.DefaultAction = GetStrFromPtrW(pDefaultAction)
         
            vFuncOrdinal = 13& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentKeyboardShortcut
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pPattern, vTblOffset, vbLong, CC_STDCALL, VarPtr(pKeyboardShortcut))
            oElement.KeyboardShortcut = GetStrFromPtrW(pKeyboardShortcut)
         
            vFuncOrdinal = 21& 'IUIAutomationElement::get_CurrentControlType
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(lControlType))
            oElement.ControlType = lControlType
         
            vFuncOrdinal = 24& 'IUIAutomationElement::get_CurrentAcceleratorKey
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(pAccKey))
            oElement.AcceleratorKey = GetStrFromPtrW(pAccKey)
         
            vFuncOrdinal = 26& 'IUIAutomationElement::get_CurrentHasKeyboardFocus
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(bHasKeyboardFocus))
            oElement.HasKeyboardFocus = bHasKeyboardFocus
         
            vFuncOrdinal = 28& 'IUIAutomationElement::get_CurrentIsEnabled
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(bIsEnabled))
            oElement.IsEnabled = bIsEnabled
         
            vFuncOrdinal = 30& 'IUIAutomationElement::get_CurrentClassName
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(pClassName))
            oElement.ClassName = GetStrFromPtrW(pClassName)
         
            vFuncOrdinal = 38& 'IUIAutomationElement::get_CurrentIsOffscreen
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(bOffScreen))
            oElement.KeyboardShortcut = bOffScreen
         
            vFuncOrdinal = 37& 'IUIAutomationElement::get_CurrentItemType
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(pItemType))
            oElement.ItemType = GetStrFromPtrW(pItemType)
         
            vFuncOrdinal = 20& 'IUIAutomationElement::get_CurrentProcessId
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(lProcID))
            oElement.ProcessID = lProcID
         
            vFuncOrdinal = 22& 'IUIAutomationElement::get_CurrentLocalizedControlType
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(pLocalControlType))
            oElement.LocalControlType = GetStrFromPtrW(pLocalControlType)
         
            vFuncOrdinal = 39& 'IUIAutomationElement::get_CurrentOrientation
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(lOrientation))
            oElement.Orientation = lOrientation
         
            vFuncOrdinal = 43& 'IUIAutomationElement::get_CurrentItemStatus
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(lItemStatus))
            oElement.ItemStatus = lOrientation
         
            vFuncOrdinal = 35& 'IUIAutomationElement::get_CurrentIsPassword
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(bIsPassword))
            oElement.IsPassword = bIsPassword
         
            vFuncOrdinal = 36& 'IUIAutomationElement::get_CurrentNativeWindowHandle
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(lHwnd))
            oElement.WindowHandle = lHwnd
         
            'Release IUIAutomationElement Interface.
            vFuncOrdinal = 2& 'IUIAutomationElement::Release
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(Me.pIElement, vTblOffset, vbEmpty, CC_STDCALL)
         
            'Add all found elements to collection.
            oElements.Add oElement
         
        End If
     
    Next lIndex
     
    'Release other Automation Interfaces.
    If Me.pIAutomation Then
        lRet = vtblCall(Me.pIElementArray, vTblOffset, vbEmpty, CC_STDCALL) 'IUIAutomationElementArray ::Release
        lRet = vtblCall(Me.pITrueCond, vTblOffset, vbEmpty, CC_STDCALL)     'IUIAutomationCondition ::Release
        lRet = vtblCall(Me.pIAutomation, vTblOffset, vbEmpty, CC_STDCALL)   'IUIAutomation::Release
    End If
 
End Sub

Private Sub ClickablePoint(ByRef X As Long, ByRef Y As Long)

    Const CC_STDCALL = 4&
    Dim Pt1 As Currency, Pt2 As POINTAPI
    Dim lClickable As Long
    Dim lRet As Long, vTblOffset As Long, vFuncOrdinal As Long

    vFuncOrdinal = 84& 'IUIAutomationElement::GetClickablePoint
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblCall(Me.pIElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(Pt1), VarPtr(lClickable))
    Call CopyMemory(Pt2, Pt1, LenB(Pt2))
    X = Pt2.X: Y = Pt2.Y

End Sub

Private Sub ScreenBoundingRectangle(X As Long, Y As Long, nWidth As Long, nHeight As Long)

    Const CC_STDCALL = 4&
    Dim lRet As Long, vTblOffset As Long, vFuncOrdinal As Long

    vFuncOrdinal = 43& 'IUIAutomationElement::get_CurrentBoundingRectangle
    vTblOffset = vFuncOrdinal * PTR_LEN

    #If Win64 Then
        Dim R As RECT_PTR
        Dim Pt1 As POINTAPI, Pt2 As POINTAPI
     
        lRet = vtblCall(Me.pIElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(R))
        Call CopyMemory(Pt1, ByVal VarPtr(R), PTR_LEN)
        Call CopyMemory(Pt2, ByVal VarPtr(R) + PTR_LEN, PTR_LEN)
        X = Pt1.X: Y = Pt1.Y
        nWidth = Pt2.X - X: nHeight = Pt2.Y - Y
    #Else
        Dim R As RECT
     
        lRet = vtblCall(Me.pIElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(R))
        With R
            X = .Left: Y = .Top
            nWidth = .Right - .Left: nHeight = .Bottom - .Top
        End With
    #End If

End Sub

Private Sub DoDefaultAct()

    Const CC_STDCALL = 4&
    Dim lRet As Long, vTblOffset As Long, vFuncOrdinal As Long
 
    vFuncOrdinal = 4& 'IID_IUIAutomationLegacyIAccessiblePattern::DoDefaultAction
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblCall(Me.pIPattern, vTblOffset, vbEmpty, CC_STDCALL)

End Sub

Private Sub Select_Item()

    Const CC_STDCALL = 4&, SELFLAG_TAKEFOCUS = 1&, SELFLAG_TAKESELECTION = 2&
    Dim lRet As Long, vTblOffset As Long, vFuncOrdinal As Long, selFlag As Long
 
    selFlag = SELFLAG_TAKEFOCUS + SELFLAG_TAKESELECTION
    vFuncOrdinal = 3& 'IUIAutomationLegacyIAccessiblePattern::Select
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblCall(Me.pIPattern, vTblOffset, vbLong, CC_STDCALL, selFlag)

End Sub



' __________________________________________ Helper Routines _______________________________________________

Private Sub DispGUID(objGuid As GUID)
    Dim lRet As Long, sTmp As String, buf(100&) As Byte
    lRet = StringFromGUID2(objGuid, VarPtr(buf(0&)), UBound(buf) - 1&)
    sTmp = buf
End Sub

Private Function GetStrFromPtrW(ByVal lpString As LongPtr) As String
   Dim lLength As Long, sBuffer As String
   lLength = lstrlen(lpString)
   sBuffer = Space$(lLength)
   Call CopyMemory(ByVal StrPtr(sBuffer), ByVal lpString, lLength * 2&)
   GetStrFromPtrW = sBuffer
End Function

Private Function vtblCall(ByVal InterfacePointer As LongPtr, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
    Dim vParamPtr() As LongPtr
    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0& To 0&)
        ReDim vParamType(0& To 0&)
    Else
        ReDim vParamPtr(0& To pCount - 1&)
        ReDim vParamType(0& To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If

     pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, vParamType(0&), vParamPtr(0&), vRtn)

    If pIndex = 0& Then
        vtblCall = vRtn
    Else
        Call SetLastError(pIndex)
    End If
End Function


2- Interface code;
VBA Code:
Option Explicit

' ReadOnly Interface.

Property Get Name() As String
    '
End Property

Property Get Role() As Long
    '
End Property

Public Property Get Description() As String
   '
End Property

Public Property Get HelpText() As String
    '
End Property

Public Property Get State() As Long
    '
End Property

Public Property Get Value() As String
    '
End Property

Public Property Get DefaultAction() As String
    '
End Property

Public Property Get KeyboardShortcut() As String
    '
End Property

Public Property Get AcceleratorKey() As String
    '
End Property

Public Property Get ControlType() As Long
    '
End Property

Public Property Get HasKeyboardFocus() As Boolean
    '
End Property

Public Property Get IsEnabled() As Boolean
    '
End Property

Public Property Get ClassName() As String
    '
End Property

Public Property Get IsOffScreen() As Boolean
    '
End Property

Public Property Get ItemType() As String
    '
End Property

Public Property Get ProcessID() As Long
    '
End Property

Public Property Get LocalControlType() As String
    '
End Property

Public Property Get Orientation() As String
    '
End Property

Public Property Get ItemStatus() As Long
    '
End Property

Public Property Get IsPassword() As Boolean
    '
End Property

Public Property Get WindowHandle() As LongPtr
    '
End Property

Public Property Get pIAutomation() As LongPtr
    '
End Property

Public Property Get pITrueCond() As LongPtr
    '
End Property

Public Property Get pIElementArray() As LongPtr
    '
End Property

Public Property Get pIPattern() As LongPtr
    '
End Property

Public Property Get pIElement() As LongPtr
    '
End Property

Public Sub DoDefaultAction()
'
End Sub

Public Sub SelectMe()
    '
End Sub

Public Sub GetClickablePoint(ByRef X As Long, ByRef Y As Long)
'
End Sub

Public Sub GetScreenBoundingRectangle(ByRef X As Long, ByRef Y As Long, nWidth As Long, nHeight As Long)
'
End Sub
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Thank you for this, Jaafar! As always, this is a useful demo to learn from.
I still haven't wrapped my head around DispCallFunc, but I feel this will help.
 
Upvote 0
@Jaafar Tribak This is very cool, I've been meaning to add something UIAutomation wise onto stdVBA for a good while now (I have stdAcc, but UIAutomation has some nice performance benefits!), but never got around to it. This example would provide a great basis for that! :)

P.S. it's super slow on my end (likely due to copy memory being agonisingly slow - it's better to use this: A minimal sample of optimised CopyMemory for VBA).
 
Upvote 0
Thank you both for the feedback.

@sancarn
P.S. it's super slow on my end (likely due to copy memory being agonisingly slow - it's better to use this: A minimal sample of optimised CopyMemory for VBA).
Also, repetitievely printing the strings in the immediate window (TreeWalk_Test example) will make it slower.

Thanks for the copymemory alternative trick in the link. I will see if/how I can incorporate it in subsequent codes.

Regards.
 
Upvote 0
UPDATE

I forgot to add the important ChildCount Property to the class. I amended the code to accomodate this Property. I also added a couple of other subtle changes.

File for downloading:
AccessibilityEx.xlsm


1- C_AccEx Class:
VBA Code:
Option Explicit

Implements IAccElement

#If Win64 Then
    Private Const NULL_PTR = 0^
    Private Const PTR_LEN = 8&
#Else
    Private Const NULL_PTR = 0&
    Private Const PTR_LEN = 4&
#End If

Public Enum TreeScope
    TreeScope_None = 0&
    TreeScope_Element = 1&
    TreeScope_Children = 2&
    TreeScope_Descendants = 4&
    TreeScope_Subtree = ((TreeScope_Element + TreeScope_Children) + TreeScope_Descendants)
End Enum

#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 lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
    Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
    Private Declare PtrSafe Function StringFromGUID2 Lib "ole32" (ByRef rguid As GUID, ByVal lpsz As LongPtr, ByVal cchMax As Long) As Long
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As GUID) As Long
    Private Declare PtrSafe Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) 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 lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
    Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
    Private Declare Function StringFromGUID2 Lib "ole32" (ByRef rguid As GUID, ByVal lpsz As LongPtr, ByVal cchMax As Long) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As GUID) As Long
    Private Declare Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
#End If

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
    
Private Type RECT_PTR
    Left As LongPtr
    Top As LongPtr
    Right As LongPtr
    Bottom As LongPtr
End Type

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0& To 7&) As Byte
End Type

Private oElements As Collection
Private oElement  As C_AccEx

Private pAutomation As LongPtr
Private pPattern As LongPtr
Private pElement As LongPtr
Private pElementArray As LongPtr
Private pChildrenArray As LongPtr
Private pTrueCond As LongPtr

Private pLegacyName As LongPtr
Private pAccKey As LongPtr
Private pItemType As LongPtr
Private pLocalControlType As LongPtr
Private pDefaultAction As LongPtr
Private pKeyboardShortcut As LongPtr
Private pClassName As LongPtr
Private pValue As LongPtr
Private pLegacyDescription As LongPtr
Private pLegacyHelp As LongPtr
Private lHwnd As LongPtr

Private lOrientation As Long
Private lItemStatus As Long
Private lProcID As Long
Private lRole As Long
Private lState As Long
Private lControlType As Long
Private lProcessID As Long
Private lChildCount As Long

Private sName As String
Private sDescription As String
Private sHelpText As String
Private sValue As String
Private sDefaultAction As String
Private sKeyboardShortcut As String
Private sAcceleratorKey As String
Private sClassName As String
Private sItemType As String
Private sLocalControlType As String

Private bHasKeyboardFocus As Boolean
Private bIsEnabled As Boolean
Private bOffScreen As Boolean
Private bIsPassword As Boolean


Private Sub Class_Initialize()
    Set oElements = New Collection
End Sub

' __________________________________________ Public Members __________________________________________________

Sub GetAccessibleChildrenFromHwnd(ByVal hwnd As LongPtr, Optional ByVal Scope As TreeScope = TreeScope_Subtree)
    If IsWindow(hwnd) = 0& Then
        MsgBox "Invalid Window Handle !":    Exit Sub
    End If
    Call FindElements(hwnd, Scope)
End Sub

Function ElementsCount() As Long
    ElementsCount = oElements.Count
End Function

Property Get Items() As Collection
    Set Items = oElements
End Property


Property Get Name() As String
    Name = sName
End Property
Property Let Name(ByVal vNewValue As String)
    sName = vNewValue
End Property

Property Get Role() As Long
    Role = lRole
End Property
Property Let Role(ByVal vNewValue As Long)
    lRole = vNewValue
End Property

Property Get Description() As String
    Description = sDescription
End Property
Property Let Description(ByVal vNewValue As String)
    sDescription = vNewValue
End Property

Property Get HelpText() As String
    HelpText = sHelpText
End Property
Property Let HelpText(ByVal vNewValue As String)
    sHelpText = vNewValue
End Property

Property Get State() As Long
    State = lState
End Property
Property Let State(ByVal vNewValue As Long)
    lState = vNewValue
End Property

Property Get Value() As String
    Value = sValue
End Property
Property Let Value(ByVal vNewValue As String)
    sValue = vNewValue
End Property

Property Get DefaultAction() As String
    DefaultAction = sDefaultAction
End Property
Property Let DefaultAction(ByVal vNewValue As String)
    sDefaultAction = vNewValue
End Property

Property Get KeyboardShortcut() As String
    KeyboardShortcut = sKeyboardShortcut
End Property
Property Let KeyboardShortcut(ByVal vNewValue As String)
    sKeyboardShortcut = vNewValue
End Property

Property Get AcceleratorKey() As String
    AcceleratorKey = sAcceleratorKey
End Property
Property Let AcceleratorKey(ByVal vNewValue As String)
    sAcceleratorKey = vNewValue
End Property

Property Get ControlType() As Long
    ControlType = lControlType
End Property
Property Let ControlType(ByVal vNewValue As Long)
    lControlType = vNewValue
End Property

Property Get HasKeyboardFocus() As Boolean
    HasKeyboardFocus = bHasKeyboardFocus
End Property
Property Let HasKeyboardFocus(ByVal vNewValue As Boolean)
    bHasKeyboardFocus = vNewValue
End Property

Property Get IsEnabled() As Boolean
    IsEnabled = bIsEnabled
End Property
Property Let IsEnabled(ByVal vNewValue As Boolean)
    bIsEnabled = vNewValue
End Property

Property Get ClassName() As String
    ClassName = sClassName
End Property
Property Let ClassName(ByVal vNewValue As String)
    sClassName = vNewValue
End Property

Property Get IsOffScreen() As Boolean
    IsOffScreen = bOffScreen
End Property
Property Let IsOffScreen(ByVal vNewValue As Boolean)
    bOffScreen = vNewValue
End Property

Property Get ItemType() As String
   ItemType = sItemType
End Property
Property Let ItemType(ByVal vNewValue As String)
    sItemType = vNewValue
End Property

Property Get ProcessID() As Long
    ProcessID = lProcessID
End Property
Property Let ProcessID(ByVal vNewValue As Long)
    lProcessID = vNewValue
End Property

Property Get LocalControlType() As String
    LocalControlType = sLocalControlType
End Property
Property Let LocalControlType(ByVal vNewValue As String)
    sLocalControlType = vNewValue
End Property

Property Get Orientation() As Long
    Orientation = lOrientation
End Property
Property Let Orientation(ByVal vNewValue As Long)
    lOrientation = vNewValue
End Property

Property Get ItemStatus() As Long
    ItemStatus = lItemStatus
End Property
Property Let ItemStatus(ByVal vNewValue As Long)
    lItemStatus = vNewValue
End Property

Property Get IsPassword() As Boolean
    IsPassword = bIsPassword
End Property
Property Let IsPassword(ByVal vNewValue As Boolean)
    bIsPassword = vNewValue
End Property

Property Get WindowHandle() As LongPtr
    WindowHandle = lHwnd
End Property
Property Let WindowHandle(ByVal vNewValue As LongPtr)
    lHwnd = vNewValue
End Property

Property Get ChildCount() As Long
    ChildCount = lChildCount
End Property
Property Let ChildCount(ByVal vNewValue As Long)
    lChildCount = vNewValue
End Property

Property Get pIAutomation() As LongPtr
    pIAutomation = pAutomation
End Property
Property Let pIAutomation(ByVal vNewValue As LongPtr)
    pAutomation = vNewValue
End Property

Property Get pIPattern() As LongPtr
    pIPattern = pPattern
End Property
Property Let pIPattern(ByVal vNewValue As LongPtr)
    pPattern = vNewValue
End Property

Property Get pITrueCond() As LongPtr
    pITrueCond = pTrueCond
End Property
Property Let pITrueCond(ByVal vNewValue As LongPtr)
    pTrueCond = vNewValue
End Property

Property Get pIElementArray() As LongPtr
    pIElementArray = pElementArray
End Property
Property Let pIElementArray(ByVal vNewValue As LongPtr)
    pElementArray = vNewValue
End Property

Property Get pIElement() As LongPtr
    pIElement = pElement
End Property
Property Let pIElement(ByVal vNewValue As LongPtr)
    pElement = vNewValue
End Property

Sub GetClickablePoint(ByRef x As Long, ByRef y As Long)
    Call ClickablePoint(x, y)
End Sub

Sub GetScreenBoundingRectangle(x As Long, y As Long, nWidth As Long, nHeight As Long)
    Call ScreenBoundingRectangle(x, y, nWidth, nHeight)
End Sub

Sub SelectMe()
    Call Select_Item
End Sub

Sub DoDefaultAction()
    Call DoDefaultAct
End Sub


' _____________________________________________ Interface Imp Routines ___________________________________________

Private Property Get IAccElement_pIAutomation() As LongPtr
    IAccElement_pIAutomation = pAutomation
End Property

Private Property Get IAccElement_pITrueCond() As LongPtr
    IAccElement_pITrueCond = pTrueCond
End Property

Private Property Get IAccElement_pIElementArray() As LongPtr
    IAccElement_pIElementArray = pElementArray
End Property

Private Property Get IAccElement_pIElement() As LongPtr
    IAccElement_pIElement = pElement
End Property

Private Property Get IAccElement_pIPattern() As LongPtr
    IAccElement_pIPattern = pPattern
End Property


Private Property Get IAccElement_DefaultAction() As String
    IAccElement_DefaultAction = sDefaultAction
End Property

Private Property Get IAccElement_Description() As String
    IAccElement_Description = sDescription
End Property

Private Property Get IAccElement_AcceleratorKey() As String
    IAccElement_AcceleratorKey = sAcceleratorKey
End Property

Private Property Get IAccElement_HelpText() As String
    IAccElement_HelpText = sHelpText
End Property

Private Property Get IAccElement_KeyboardShortcut() As String
    IAccElement_KeyboardShortcut = sKeyboardShortcut
End Property

Private Property Get IAccElement_Name() As String
    IAccElement_Name = sName
End Property

Private Property Get IAccElement_Role() As Long
    IAccElement_Role = lRole
End Property

Private Property Get IAccElement_State() As Long
    IAccElement_State = lState
End Property

Private Property Get IAccElement_Value() As String
    IAccElement_Value = sValue
End Property

Private Property Get IAccElement_ClassName() As String
    IAccElement_ClassName = sClassName
End Property

Private Property Get IAccElement_ControlType() As Long
    IAccElement_ControlType = lControlType
End Property

Private Property Get IAccElement_HasKeyboardFocus() As Boolean
    IAccElement_HasKeyboardFocus = bHasKeyboardFocus
End Property

Private Property Get IAccElement_IsEnabled() As Boolean
    IAccElement_IsEnabled = bIsEnabled
End Property

Private Property Get IAccElement_IsOffScreen() As Boolean
    IAccElement_IsOffScreen = bOffScreen
End Property

Private Property Get IAccElement_IsPassword() As Boolean
    IAccElement_IsPassword = bIsPassword
End Property

Private Property Get IAccElement_ItemStatus() As Long
    IAccElement_ItemStatus = lItemStatus
End Property

Private Property Get IAccElement_ItemType() As String
    IAccElement_ItemType = sItemType
End Property

Private Property Get IAccElement_LocalControlType() As String
    IAccElement_LocalControlType = sLocalControlType
End Property

Private Property Get IAccElement_Orientation() As String
    IAccElement_Orientation = lOrientation
End Property

Private Property Get IAccElement_ProcessID() As Long
    IAccElement_ProcessID = lProcessID
End Property

Private Property Get IAccElement_WindowHandle() As LongPtr
    IAccElement_WindowHandle = lHwnd
End Property

Private Property Get IAccElement_ChildCount() As Long
    IAccElement_ChildCount = lChildCount
End Property

Private Sub IAccElement_SelectMe()
    Call Select_Item
End Sub

Private Sub IAccElement_DoDefaultAction()
    Call DoDefaultAct
End Sub

Private Sub IAccElement_GetClickablePoint(ByRef x As Long, ByRef y As Long)
    Call ClickablePoint(x, y)
End Sub

Private Sub IAccElement_GetScreenBoundingRectangle(ByRef x As Long, ByRef y As Long, ByRef nWidth As Long, ByRef nHeight As Long)
    Call ScreenBoundingRectangle(x, y, nWidth, nHeight)
End Sub


' ___________________________________________ Private Routines __________________________________________________

Private Function GetAutomationPtr() As LongPtr

    Const IID_CUIAUTOMATION = "{FF48DBA4-60EF-4201-AA87-54103EEF594E}"
    Const IID_IUIAUTOMATION = "{30CBE57D-D9D0-452A-AB13-7AC5AC4825EE}"
    Const CLSCTX_INPROC_SERVER = &H1, CC_STDCALL = 4&, S_OK = 0&
    
    Dim iidCuiAuto As GUID, iidIuiAuto As GUID, lRet As Long
    
    lRet = CLSIDFromString(StrPtr(IID_CUIAUTOMATION), iidCuiAuto)
    Call DispGUID(iidCuiAuto)
    lRet = CLSIDFromString(StrPtr(IID_IUIAUTOMATION), iidIuiAuto)
    Call DispGUID(iidIuiAuto)
    lRet = CoCreateInstance(iidCuiAuto, NULL_PTR, CLSCTX_INPROC_SERVER, iidIuiAuto, pAutomation)
    
    If lRet = S_OK Then GetAutomationPtr = pAutomation

End Function

Private Sub FindElements(ByVal hwnd As LongPtr, Optional ByVal Scope As TreeScope = TreeScope_Subtree)

    Const CC_STDCALL = 4&, TreeScope_Descendants = 4&, UIA_LegacyIAccessiblePatternId = 10018&
    Const IID_IUIAutomationLegacyIAccessiblePattern = "{828055ad-355b-4435-86d5-3b51c14a9b1b}"
    Dim lIndex As Long, lElementsCount As Long
    Dim lRet As Long, vTblOffset As Long, vFuncOrdinal As Long
    Dim iidCuiAuto As GUID


    pAutomation = GetAutomationPtr
    If pAutomation = NULL_PTR Then MsgBox "Automation failed.": Exit Sub
 
    vFuncOrdinal = 6& ' IUIAutomation::ElementFromHandle
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblCall(pAutomation, vTblOffset, vbLong, CC_STDCALL, hwnd, VarPtr(pElement))
    
    vFuncOrdinal = 21& ' IUIAutomation::CreateTrueCondition
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblCall(pAutomation, vTblOffset, vbLong, CC_STDCALL, VarPtr(pTrueCond))
  
    vFuncOrdinal = 6& ' IUIAutomationElement::FindAll
    vTblOffset = vFuncOrdinal * PTR_LEN ' IUIAutomationElement::FindAll
    lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, Scope, pTrueCond, VarPtr(pElementArray))

    vFuncOrdinal = 3& ' IUIAutomationElementArray :get_Length
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblCall(pElementArray, vTblOffset, vbLong, CC_STDCALL, VarPtr(lElementsCount))

    If lElementsCount = 0& Then
        MsgBox "No Accessible descendants were found.": Exit Sub
    End If
    
    For lIndex = 0& To lElementsCount - 1&
    
        vFuncOrdinal = 4& ' IUIAutomationElementArray :GetElement
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblCall(pElementArray, vTblOffset, vbLong, CC_STDCALL, lIndex, VarPtr(pElement))
        
        lRet = CLSIDFromString(StrPtr(IID_IUIAutomationLegacyIAccessiblePattern), iidCuiAuto)
        Call DispGUID(iidCuiAuto)
        vFuncOrdinal = 14& 'IID_IUIAutomationElement::GetCurrentPatternAs
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, UIA_LegacyIAccessiblePatternId, VarPtr(iidCuiAuto), VarPtr(pPattern))
      
        If pPattern <> NULL_PTR Then
            
            'Store Interfaces Ptrs in each new class instance.
            Set oElement = New C_AccEx
            With oElement
                .pIAutomation = pAutomation
                .pITrueCond = pTrueCond
                .pIElementArray = pElementArray
                .pIElement = pElement
                .pIPattern = pPattern
            End With
            
            'Retrieve descendants properties.
            vFuncOrdinal = 7& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentName
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pPattern, vTblOffset, vbLong, CC_STDCALL, VarPtr(pLegacyName))
            oElement.Name = GetStrFromPtrW(pLegacyName)
            
            vFuncOrdinal = 10& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentRole
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pPattern, vTblOffset, vbLong, CC_STDCALL, VarPtr(lRole))
            oElement.Role = lRole
            
            vFuncOrdinal = 9& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentDescription
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pPattern, vTblOffset, vbLong, CC_STDCALL, VarPtr(pLegacyDescription))
            oElement.Description = GetStrFromPtrW(pLegacyDescription)
            
            vFuncOrdinal = 12& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentHelp
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pPattern, vTblOffset, vbLong, CC_STDCALL, VarPtr(pLegacyHelp))
            oElement.HelpText = GetStrFromPtrW(pLegacyHelp)
            
            vFuncOrdinal = 11& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentState
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pPattern, vTblOffset, vbLong, CC_STDCALL, VarPtr(lState))
            oElement.State = lState
            
            vFuncOrdinal = 8& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentValue
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pPattern, vTblOffset, vbLong, CC_STDCALL, VarPtr(pValue))
            oElement.Value = GetStrFromPtrW(pValue)
            
            vFuncOrdinal = 15& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentDefaultAction
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pPattern, vTblOffset, vbLong, CC_STDCALL, VarPtr(pDefaultAction))
            oElement.DefaultAction = GetStrFromPtrW(pDefaultAction)
            
            vFuncOrdinal = 13& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentKeyboardShortcut
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pPattern, vTblOffset, vbLong, CC_STDCALL, VarPtr(pKeyboardShortcut))
            oElement.KeyboardShortcut = GetStrFromPtrW(pKeyboardShortcut)
            
           'Retrieve ChildCount.
            vFuncOrdinal = 6& ' IUIAutomationElement::FindAll
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, TreeScope_Children, pTrueCond, VarPtr(pChildrenArray))
            
            vFuncOrdinal = 3& ' IUIAutomationElementArray :get_Length
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pChildrenArray, vTblOffset, vbLong, CC_STDCALL, VarPtr(lChildCount))
            oElement.ChildCount = lChildCount
            
            vFuncOrdinal = 21& 'IUIAutomationElement::get_CurrentControlType
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(lControlType))
            oElement.ControlType = lControlType
            
            vFuncOrdinal = 24& 'IUIAutomationElement::get_CurrentAcceleratorKey
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(pAccKey))
            oElement.AcceleratorKey = GetStrFromPtrW(pAccKey)
            
            vFuncOrdinal = 26& 'IUIAutomationElement::get_CurrentHasKeyboardFocus
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(bHasKeyboardFocus))
            oElement.HasKeyboardFocus = bHasKeyboardFocus
            
            vFuncOrdinal = 28& 'IUIAutomationElement::get_CurrentIsEnabled
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(bIsEnabled))
            oElement.IsEnabled = bIsEnabled
            
            vFuncOrdinal = 30& 'IUIAutomationElement::get_CurrentClassName
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(pClassName))
            oElement.ClassName = GetStrFromPtrW(pClassName)
            
            vFuncOrdinal = 38& 'IUIAutomationElement::get_CurrentIsOffscreen
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(bOffScreen))
            oElement.KeyboardShortcut = bOffScreen
            
            vFuncOrdinal = 37& 'IUIAutomationElement::get_CurrentItemType
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(pItemType))
            oElement.ItemType = GetStrFromPtrW(pItemType)
            
            vFuncOrdinal = 20& 'IUIAutomationElement::get_CurrentProcessId
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(lProcID))
            oElement.ProcessID = lProcID
            
            vFuncOrdinal = 22& 'IUIAutomationElement::get_CurrentLocalizedControlType
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(pLocalControlType))
            oElement.LocalControlType = GetStrFromPtrW(pLocalControlType)
            
            vFuncOrdinal = 39& 'IUIAutomationElement::get_CurrentOrientation
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(lOrientation))
            oElement.Orientation = lOrientation
            
            vFuncOrdinal = 43& 'IUIAutomationElement::get_CurrentItemStatus
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(lItemStatus))
            oElement.ItemStatus = lOrientation
            
            vFuncOrdinal = 35& 'IUIAutomationElement::get_CurrentIsPassword
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(bIsPassword))
            oElement.IsPassword = bIsPassword
            
            vFuncOrdinal = 36& 'IUIAutomationElement::get_CurrentNativeWindowHandle
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblCall(pElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(lHwnd))
            oElement.WindowHandle = lHwnd
            
            'Release Children IUIAutomationElementArray and IUIAutomationElement Interfaces.
            vFuncOrdinal = 2& 'IUIAutomationElement::Release
            vTblOffset = vFuncOrdinal * PTR_LEN
            
           If pChildrenArray Then
                lRet = vtblCall(pChildrenArray, vTblOffset, vbEmpty, CC_STDCALL)
           End If
            
            If Me.pIElement Then
                lRet = vtblCall(Me.pIElement, vTblOffset, vbEmpty, CC_STDCALL)
            End If
            
            'Add all found elements to collection.
            oElements.Add oElement
            
        End If
        
    Next lIndex
        
    'Release other Automation Interfaces.
    If Me.pIAutomation Then
        lRet = vtblCall(Me.pIElementArray, vTblOffset, vbEmpty, CC_STDCALL) 'IUIAutomationElementArray ::Release
        lRet = vtblCall(Me.pITrueCond, vTblOffset, vbEmpty, CC_STDCALL)     'IUIAutomationCondition ::Release
        lRet = vtblCall(Me.pIAutomation, vTblOffset, vbEmpty, CC_STDCALL)   'IUIAutomation::Release
    End If
    
End Sub

Private Sub ClickablePoint(ByRef x As Long, ByRef y As Long)

    Const CC_STDCALL = 4&
    Dim Pt1 As Currency, Pt2 As POINTAPI
    Dim lClickable As Long
    Dim lRet As Long, vTblOffset As Long, vFuncOrdinal As Long

    vFuncOrdinal = 84& 'IUIAutomationElement::GetClickablePoint
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblCall(Me.pIElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(Pt1), VarPtr(lClickable))
    Call CopyMemory(Pt2, Pt1, LenB(Pt2))
    x = Pt2.x: y = Pt2.y

End Sub

Private Sub ScreenBoundingRectangle(x As Long, y As Long, nWidth As Long, nHeight As Long)

    Const CC_STDCALL = 4&
    Dim lRet As Long, vTblOffset As Long, vFuncOrdinal As Long

    vFuncOrdinal = 43& 'IUIAutomationElement::get_CurrentBoundingRectangle
    vTblOffset = vFuncOrdinal * PTR_LEN

    #If Win64 Then
        Dim r As RECT_PTR
        Dim Pt1 As POINTAPI, Pt2 As POINTAPI
        
        lRet = vtblCall(Me.pIElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(r))
        Call CopyMemory(Pt1, ByVal VarPtr(r), PTR_LEN)
        Call CopyMemory(Pt2, ByVal VarPtr(r) + PTR_LEN, PTR_LEN)
        x = Pt1.x: y = Pt1.y
        nWidth = Pt2.x - x: nHeight = Pt2.y - y
    #Else
        Dim r As RECT
        
        lRet = vtblCall(Me.pIElement, vTblOffset, vbLong, CC_STDCALL, VarPtr(r))
        With r
            x = .Left: y = .Top
            nWidth = .Right - .Left: nHeight = .Bottom - .Top
        End With
    #End If

End Sub

Private Sub DoDefaultAct()

    Const CC_STDCALL = 4&
    Dim lRet As Long, vTblOffset As Long, vFuncOrdinal As Long
    
    vFuncOrdinal = 4& 'IID_IUIAutomationLegacyIAccessiblePattern::DoDefaultAction
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblCall(Me.pIPattern, vTblOffset, vbEmpty, CC_STDCALL)

End Sub

Private Sub Select_Item()

    Const CC_STDCALL = 4&, SELFLAG_TAKEFOCUS = 1&, SELFLAG_TAKESELECTION = 2&
    Dim lRet As Long, vTblOffset As Long, vFuncOrdinal As Long, selFlag As Long
    
    selFlag = SELFLAG_TAKEFOCUS + SELFLAG_TAKESELECTION
    vFuncOrdinal = 3& 'IUIAutomationLegacyIAccessiblePattern::Select
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblCall(Me.pIPattern, vTblOffset, vbLong, CC_STDCALL, selFlag)

End Sub



' __________________________________________ Helper Routines _______________________________________________

Private Sub DispGUID(objGuid As GUID)
    Dim lRet As Long, sTmp As String, buf(100&) As Byte
    lRet = StringFromGUID2(objGuid, VarPtr(buf(0&)), UBound(buf) - 1&)
    sTmp = buf
End Sub

Private Function GetStrFromPtrW(ByVal lpString As LongPtr) As String
   Dim lLength As Long, sBuffer As String
   lLength = lstrlen(lpString)
   sBuffer = Space$(lLength)
   Call CopyMemory(ByVal StrPtr(sBuffer), ByVal lpString, lLength * 2&)
   GetStrFromPtrW = sBuffer
End Function

Private Function vtblCall(ByVal InterfacePointer As LongPtr, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
    Dim vParamPtr() As LongPtr
    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0& To 0&)
        ReDim vParamType(0& To 0&)
    Else
        ReDim vParamPtr(0& To pCount - 1&)
        ReDim vParamType(0& To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If

     pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, vParamType(0&), vParamPtr(0&), vRtn)

    If pIndex = 0& Then
        vtblCall = vRtn
    Else
        Call SetLastError(pIndex)
    End If
End Function


2- IAccElement Class Interface
VBA Code:
Option Explicit

' ReadOnly Interface.

Property Get Name() As String
    '
End Property

Property Get Role() As Long
    '
End Property

Public Property Get Description() As String
   '
End Property

Public Property Get HelpText() As String
    '
End Property

Public Property Get State() As Long
    '
End Property

Public Property Get Value() As String
    '
End Property

Public Property Get DefaultAction() As String
    '
End Property

Public Property Get KeyboardShortcut() As String
    '
End Property

Public Property Get AcceleratorKey() As String
    '
End Property

Public Property Get ControlType() As Long
    '
End Property

Public Property Get HasKeyboardFocus() As Boolean
    '
End Property

Public Property Get IsEnabled() As Boolean
    '
End Property

Public Property Get ClassName() As String
    '
End Property

Public Property Get IsOffScreen() As Boolean
    '
End Property

Public Property Get ItemType() As String
    '
End Property

Public Property Get ProcessID() As Long
    '
End Property

Public Property Get LocalControlType() As String
    '
End Property

Public Property Get Orientation() As String
    '
End Property

Public Property Get ItemStatus() As Long
    '
End Property

Public Property Get IsPassword() As Boolean
    '
End Property

Public Property Get WindowHandle() As LongPtr
    '
End Property

Public Property Get ChildCount() As Long
    '
End Property

Public Property Get pIAutomation() As LongPtr
    '
End Property

Public Property Get pITrueCond() As LongPtr
    '
End Property

Public Property Get pIElementArray() As LongPtr
    '
End Property

Public Property Get pIPattern() As LongPtr
    '
End Property

Public Property Get pIElement() As LongPtr
    '
End Property

Public Sub DoDefaultAction()
'
End Sub

Public Sub SelectMe()
    '
End Sub

Public Sub GetClickablePoint(ByRef x As Long, ByRef y As Long)
'
End Sub

Public Sub GetScreenBoundingRectangle(ByRef x As Long, ByRef y As Long, nWidth As Long, nHeight As Long)
'
End Sub
 
Upvote 0

Forum statistics

Threads
1,216,500
Messages
6,131,016
Members
449,615
Latest member
Nic0la

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top