Option Explicit
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
' Definitions and Procedures relating to Accessibility, used by the Ribbon VBA '
' Demonstration UserForm. The constants have been lifted from oleacc.h, and are '
' just a subset of those available. '
' '
' Tony Jollans, August 2008. '
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
Public Const CHILDID_SELF As Long = &H0&
Private Const STATE_SYSTEM_UNAVAILABLE As Long = &H1&
Private Const STATE_SYSTEM_INVISIBLE As Long = &H8000&
Private Const STATE_SYSTEM_SELECTED As Long = &H2&
Public Enum RoleNumber
ROLE_SYSTEM_CLIENT = &HA&
ROLE_SYSTEM_PANE = &H10&
ROLE_SYSTEM_GROUPING = &H14&
ROLE_SYSTEM_TOOLBAR = &H16&
ROLE_SYSTEM_PROPERTYPAGE = &H26&
ROLE_SYSTEM_GRAPHIC = &H28&
ROLE_SYSTEM_STATICTEXT = &H29&
ROLE_SYSTEM_Text = &H2A&
ROLE_SYSTEM_PAGETABLIST = &H3C&
End Enum
Private Enum NavigationDirection
NAVDIR_FIRSTCHILD = &H7&
End Enum
Private Declare Function AccessibleChildren _
Lib "oleacc.dll" _
(ByVal paccContainer As Object, _
ByVal iChildStart As Long, _
ByVal cChildren As Long, _
rgvarChildren As Variant, _
pcObtained As Long) _
As Long
Private Declare Function GetRoleText _
Lib "oleacc.dll" _
Alias "GetRoleTextA" _
(ByVal dwRole As Long, _
lpszRole As Any, _
ByVal cchRoleMax As Long) _
As Long
Public Type ChildList
Objects() As IAccessible
Levels() As Long
SelectedIndex As Long
End Type
Dim RibbonPropPage As IAccessible
Dim ActiveTabPropPage As IAccessible
Dim TabInfo As ChildList
Dim GroupInfo As ChildList
Dim ItemInfo As ChildList
Dim Initialised As Boolean
Sub Click_Refresh()
ClickCustomButton "Smart View", "Data", "Refresh"
End Sub
Public Sub ClickCustomButton(strTab As String, strGroup As String, strCaption As String)
Dim TabName As String
Dim RibbonPaneClient As IAccessible
Dim ndx As Long
Dim RibbonTab As IAccessible
Dim PageTabListClient As IAccessible
Dim GroupToolBar As IAccessible
Dim NamesAndRoles() As Variant
Dim DefaultAction As String
Dim n As Long
Dim j As Long
Set RibbonPropPage = GetAccessible(Application.CommandBars("Ribbon"), _
ROLE_SYSTEM_PROPERTYPAGE, _
"Ribbon")
Set PageTabListClient = GetAccessible(RibbonPropPage, _
ROLE_SYSTEM_PAGETABLIST, _
"Ribbon Tabs", _
True)
TabInfo = GetListOfChildren(PageTabListClient)
NamesAndRoles = NameAndRoleText(TabInfo)
For n = LBound(NamesAndRoles(0)) To UBound(NamesAndRoles(0))
If StrComp(NamesAndRoles(0)(n), strTab, vbTextCompare) = 0 Then
Set RibbonTab = TabInfo.Objects(n)
Set RibbonPaneClient = GetAccessible(RibbonPropPage, _
ROLE_SYSTEM_PANE, _
"Lower Ribbon", _
True)
Set ActiveTabPropPage = GetAccessible(RibbonPaneClient, _
ROLE_SYSTEM_PROPERTYPAGE, _
RibbonTab.accName(CHILDID_SELF))
GroupInfo = GetListOfChildren(ActiveTabPropPage, GetDescendents:=False)
NamesAndRoles = NameAndRoleText(GroupInfo)
For j = LBound(NamesAndRoles(0)) To UBound(NamesAndRoles(0))
If StrComp(NamesAndRoles(0)(j), strGroup, vbTextCompare) = 0 Then
Set GroupToolBar = GetAccessible(ActiveTabPropPage, _
ROLE_SYSTEM_TOOLBAR, _
GroupInfo.Objects(j) _
.accName(CHILDID_SELF))
ItemInfo = GetListOfChildren(GroupToolBar)
NamesAndRoles = NameAndRoleText(ItemInfo, _
IncludeRoleText:=True)
For ndx = LBound(NamesAndRoles(0)) To UBound(NamesAndRoles(0))
If StrComp(NamesAndRoles(0)(ndx), strCaption, vbTextCompare) = 0 Then
ItemInfo.Objects(ndx).accDoDefaultAction CHILDID_SELF
Exit Sub
End If
Next ndx
Exit Sub
End If
Next j
Exit Sub
End If
Next n
End Sub
Public Function GetAccessible _
(Element As IAccessible, _
RoleWanted As RoleNumber, _
NameWanted As String, _
Optional GetClient As Boolean) _
As IAccessible
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
' This procedure recursively searches the accessibility hierarchy, starting '
' with the element given, for an object matching the given name and role. '
' If requested, the Client object, assumed to be the first child, will be '
' returned instead of its parent. '
' '
' Calls: GetChildren to, well, get children. '
' Itself, recursively, to move down the hierarchy '
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
Dim ChildrenArray()
Dim Child As IAccessible
Dim ndxChild As Long
Dim ReturnElement As IAccessible
If Element.accRole(CHILDID_SELF) = RoleWanted _
And Element.accName(CHILDID_SELF) = NameWanted Then
Set ReturnElement = Element
Else ' not found yet
ChildrenArray = GetChildren(Element)
If (Not ChildrenArray) <> True Then
For ndxChild = LBound(ChildrenArray) To UBound(ChildrenArray)
If TypeOf ChildrenArray(ndxChild) Is IAccessible Then
Set Child = ChildrenArray(ndxChild)
Set ReturnElement = GetAccessible(Child, _
RoleWanted, _
NameWanted)
If Not ReturnElement Is Nothing Then Exit For
End If ' Child is IAccessible
Next ndxChild
End If ' there are children
End If ' still looking
If GetClient Then
Set ReturnElement = ReturnElement.accNavigate(NAVDIR_FIRSTCHILD, _
CHILDID_SELF)
End If
Set GetAccessible = ReturnElement
End Function
Public Function GetListOfChildren _
(Parent As IAccessible, _
Optional GetDescendents As Boolean = True) _
As ChildList
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
' Given a parent IAccessible object, will return a (UDT ChildList) array of '
' its children. Each returned object will be the bottom one of a leg in the '
' Accessibility hierarchy, unless told not to look at children's children. '
' '
' Calls: AddChildToList to populate the return array '
' Itself, recursively, to process descendents '
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
Dim ChildInfo As ChildList
Dim ndxChild As Long
Dim Child As IAccessible
Dim LocalChildren() As Variant
Dim LocalAncestry() As IAccessible
Dim GrandChildInfo As ChildList
Dim ndxGrandChild As Long
Dim GrandChild As IAccessible
LocalChildren = GetChildren(Parent)
If (Not LocalChildren) <> True Then
For ndxChild = LBound(LocalChildren) To UBound(LocalChildren)
Set Child = LocalChildren(ndxChild)
If Child.accRole(CHILDID_SELF) <> ROLE_SYSTEM_GRAPHIC _
And Child.accRole(CHILDID_SELF) <> ROLE_SYSTEM_STATICTEXT Then
If ((Child.accState(CHILDID_SELF) _
And (STATE_SYSTEM_UNAVAILABLE _
Or STATE_SYSTEM_INVISIBLE)) = 0) Then
If Child.accChildCount = 0 _
Or GetDescendents = False Then
AddChildToList Child, ChildInfo
Else
GrandChildInfo = GetListOfChildren(Child)
If (Not GrandChildInfo.Objects) <> True Then
For ndxGrandChild = LBound(GrandChildInfo.Objects) _
To UBound(GrandChildInfo.Objects)
Set GrandChild _
= GrandChildInfo.Objects(ndxGrandChild)
AddChildToList GrandChild, ChildInfo
ChildInfo.Levels(UBound(ChildInfo.Objects)) _
= GrandChildInfo.Levels(ndxGrandChild) + 1
Next ndxGrandChild
End If ' Any grandchildren found?
End If ' Check for grandchildren?
End If ' Not unavailable
End If ' Not (graphic or text)
Next ndxChild
End If ' Any children?
GetListOfChildren = ChildInfo
End Function
Private Sub AddChildToList _
(Child As IAccessible, _
ChildInfo As ChildList)
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
' Adds an array entry and fills it with the passed IAccessible object. If '
' the object is the currently selected one, the fact is recorded. '
' '
' Called by: GetListOfChildren '
' Calls: Nothing '
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
With ChildInfo
If (Not .Objects) = True Then
ReDim .Objects(0 To 0)
ReDim .Levels(LBound(.Objects) To UBound(.Objects))
Else
ReDim Preserve .Objects(LBound(.Objects) To UBound(.Objects) + 1)
ReDim Preserve .Levels(LBound(.Objects) To UBound(.Objects))
End If
Set .Objects(UBound(.Objects)) = Child
If ((Child.accState(CHILDID_SELF) And (STATE_SYSTEM_SELECTED)) _
= STATE_SYSTEM_SELECTED) Then
.SelectedIndex = UBound(.Objects)
End If
End With ' ChildInfo
End Sub
Private Function GetChildren _
(Element As IAccessible) _
As Variant()
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
' General purpose subroutine to get an array of children of an IAccessible '
' object. The returned array is Variant because the elements may be either '
' IAccessible objects or simple (Long) elements, and the caller must treat '
' them appropriately. '
' '
' Called by: GetAccessible when searching for an Accessible element '
' GetListOfChildren when retrieving a list of children '
' Calls: AccessibleChildren API '
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
Const FirstChild As Long = 0&
Dim NumChildren As Long
Dim NumReturned As Long
Dim ChildrenArray()
NumChildren = Element.accChildCount
If NumChildren > 0 Then
ReDim ChildrenArray(NumChildren - 1)
AccessibleChildren Element, FirstChild, NumChildren, _
ChildrenArray(0), NumReturned
End If
GetChildren = ChildrenArray
End Function
Public Function RoleText _
(Role As RoleNumber) _
As String
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
' Just a wrapper for the GetRoleText API. '
' '
' Calls: GetRoleText API - once to get the length and once to get the text. '
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
Dim RoleTemp As String
Dim RoleTextLength As Long
Dim RoleChar() As Byte
Dim ndxRoleChar As Long
RoleTextLength = GetRoleText(Role, ByVal 0, 0&)
ReDim RoleChar(0 To RoleTextLength)
GetRoleText Role, RoleChar(LBound(RoleChar)), RoleTextLength + 1
For ndxRoleChar = LBound(RoleChar) To UBound(RoleChar) - 1
RoleTemp = RoleTemp & Chr(RoleChar(ndxRoleChar))
Next ndxRoleChar
RoleText = RoleTemp
End Function
Private Function NameAndRoleText _
(Info As ChildList, _
Optional IncludeRoleText As Boolean = False) _
As Variant()
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
' Builds compound object names and role texts from an IAccessible object '
' and its ancestors up to the appropriate level, as previously determined. '
' The ancestors have not been stored, so are collected here into a simple '
' array before building up the strings. '
' '
' Calls: AppendToString to append text, if non-duplicate, and a separator, '
' if necessary, to a name or role string. '
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
Dim ReturnArray(0 To 1)
Dim NamesArray() As String
Dim RolesArray() As String
ReDim NamesArray(LBound(Info.Objects) To UBound(Info.Objects))
If IncludeRoleText Then
ReDim RolesArray(LBound(Info.Objects) To UBound(Info.Objects))
End If
Dim Ancestry() As IAccessible
Dim AncestralName As String
Dim ndxObject As Long
Dim ndxAncestry As Long
For ndxObject = LBound(Info.Objects) To UBound(Info.Objects)
ReDim Ancestry(0 To Info.Levels(ndxObject))
Set Ancestry(LBound(Ancestry)) = Info.Objects(ndxObject)
For ndxAncestry = LBound(Ancestry) + 1 To UBound(Ancestry)
Set Ancestry(ndxAncestry) = Ancestry(ndxAncestry - 1).accParent
Next ndxAncestry
For ndxAncestry = UBound(Ancestry) To LBound(Ancestry) Step -1
AncestralName = ""
If ndxAncestry < UBound(Ancestry) Then
AncestralName = Ancestry(ndxAncestry + 1).accName(CHILDID_SELF)
End If
If Ancestry(ndxAncestry).accName(CHILDID_SELF) _
<> AncestralName Then
AppendToString NamesArray(ndxObject), _
Ancestry(ndxAncestry).accName(CHILDID_SELF)
End If
If IncludeRoleText Then
If Ancestry(ndxAncestry).accRole(CHILDID_SELF) _
<> ROLE_SYSTEM_GROUPING Then
AppendToString RolesArray(ndxObject), _
RoleText(Ancestry(ndxAncestry) _
.accRole(CHILDID_SELF))
End If
End If
Next ndxAncestry
Next ndxObject
NameAndRoleText = Array(NamesArray(), RolesArray())
End Function
Private Sub AppendToString(NameOrRole As String, Appendix As String)
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
' Called from NameAndRoleText (q.v., above) to append appropriate text to a '
' name or role string. '
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
Const TextSeparator As String = " - "
If NameOrRole <> "" Then
If right(NameOrRole, Len(TextSeparator)) <> TextSeparator Then
NameOrRole = NameOrRole & TextSeparator
End If
End If
NameOrRole = NameOrRole & Appendix
End Sub
