UIAutomationClient elementFromPoint With VBA error "User-Defined type may not be passed ByVal"

1.1k Views Asked by At

Is there a way to use ElementfromPoint from UIAutomationClient with VBA (EXCEL)

I have always an compilation error : "User-Defined type may not be passed ByVal"

Sub Test_ElementFromPoint()
Dim uiAuto As New UIAutomationClient.CUIAutomation8
Dim elmRibbon As UIAutomationClient.IUIAutomationElement
Dim pt As tagPOINT

pt.x = 541
pt.y = 99
Set elmRibbon = uiAuto.ElementFromPoint(pt)
MsgBox elmRibbon.CurrentName
End Sub

Well if i can't use elementfromPoint from vba i can use AccessibleObjectFromPoint from Iaccessible to start my query but with it i don't get all the information (.currentHelpText) from ElementFromIAccessible

Code 1

Public Sub Sample()
    MsgBox "button", vbSystemModal
    TrouveButton "Paste"
End Sub

Public Sub TrouveButton(ByVal TabName As String)
    Dim uiAuto As UIAutomationClient.CUIAutomation
    Dim elmRibbon As UIAutomationClient.IUIAutomationElement
    Dim elmRibbonTab As UIAutomationClient.IUIAutomationElement
    Dim cndProperty As UIAutomationClient.IUIAutomationCondition
    Dim aryRibbonTab As UIAutomationClient.IUIAutomationElementArray
    Dim ptnAcc As UIAutomationClient.IUIAutomationLegacyIAccessiblePattern
    Dim accRibbon As Office.IAccessible
    Dim i As Long

    Set elmRibbonTab = Nothing    '???
    Set uiAuto = New UIAutomationClient.CUIAutomation
    Set accRibbon = Application.CommandBars("Ribbon")
    Set elmRibbon = uiAuto.ElementFromIAccessible(accRibbon, 0)
     Set cndProperty = uiAuto.CreatePropertyCondition(UIA_ClassNamePropertyId, "NetUIRibbonButton")

    Set aryRibbonTab = elmRibbon.FindAll(TreeScope_Subtree, cndProperty)
    For i = 0 To aryRibbonTab.Length - 1
        Debug.Print aryRibbonTab.GetElement(i).CurrentName
        If aryRibbonTab.GetElement(i).CurrentName = TabName Then
            Set elmRibbonTab = aryRibbonTab.GetElement(i)
            Exit For
        End If
    Next
    If elmRibbonTab Is Nothing Then Exit Sub
    With elmRibbonTab
        MsgBox "Name: " & .CurrentName _
             & vbCr & "------------------------------------" _
             & vbCr & "CurrentHelpText: " & CStr(.CurrentHelpText) , , "ui automation"
    End With
End Sub

code 2

Option Explicit

Private Type POINTAPI
    x As Long
    Y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    #If Win64 Then
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal arg1 As LongPtr, ppacc As IAccessible, pvarChild As Variant) As Long
        Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    #Else
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    #End If
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If

Private Const CHILDID_SELF = &H0&
Private Const S_OK As Long = &H0


Sub Sample2()
'move the mouse on PASTE BUTTON 
    Beep
    Application.OnTime DateAdd("s", 3, Now), "get_element_under_mouse"
End Sub

Private Sub get_element_under_mouse()
    Dim oIA As IAccessible
    Dim oCmbar As CommandBar
    Dim lResult As Long
    Dim tPt As POINTAPI
    Dim oButton As IAccessible

    GetCursorPos tPt

    #If Win64 Then
        Dim lngPtr As LongPtr
        CopyMemory lngPtr, tPt, LenB(tPt)
        lResult = AccessibleObjectFromPoint(lngPtr, oIA, 0)
    #Else
        lResult = AccessibleObjectFromPoint(tPt.x, tPt.Y, oIA, 0)
    #End If

    If lResult = S_OK Then
        '  On Error Resume Next

    End If

    Dim uiAuto As UIAutomationClient.CUIAutomation
    Dim elmRibbon As UIAutomationClient.IUIAutomationElement
    Dim uielmt As UIAutomationClient.IUIAutomationElement
    Dim cndProperty As UIAutomationClient.IUIAutomationCondition

    Dim i As Long

    On Error Resume Next
    Set uiAuto = New UIAutomationClient.CUIAutomation

    ' uiAuto.p
    Set elmRibbon = uiAuto.ElementFromIAccessible(oIA, 0)

    If Not elmRibbon Is Nothing Then
        MsgBox "Name: " & elmRibbon.CurrentName _
             & vbCr & "------------------------------------" _
             & vbCr & "CurrentHelpText: " & CStr(elmRibbon.CurrentHelpText) , , "ui automation"

End If

End Sub
0

There are 0 best solutions below