In my previous
post I discussed about using Accessibility API to control Windows Start Menu. For this blogpost exercise we will control a popup menu using AA.
For those who are familiar with VBA, they would know outright that class modules cannot use AddressOf operator within the class definition. In the spirit of Object Oriented programming, it would have been better to use solely class module for this but due to AddressOf requirements that it should be in a module then we will try to mix and match using both Class module and a module. The code is not a elegant as I hope it would be but this is the way VBA was designed.
Now let us get our hands dirty, first we will create a class module named CPopupMenuController. This is a very simple class module, in the initialization section we set a hook to receive focus events coming from the system and remove the hook once the object is destroyed. See below for the code:
'------------------------------------------------------------------------------
' Developed by : Techno.Scavenger
' Licensed to : Mankind
' Date : 26Oct2008 @ 3:06 PM + 8 GMT (Sunday @home)
' Warranty
' THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
' “Techno.Scavenger” OR ANY OTHER CONTRIBUTOR BE LIABLE FOR ANY CLAIM,
' DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
' OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE
' USE OR OTHER DEALINGS IN THE SOFTWARE.
' Note:
' You can do whatever with this code
'------------------------------------------------------------------------------
'References:
'http://msdn.microsoft.com/en-us/library/ms697639(VS.85).aspx
'http://www.microsoft.com/downloads/details.aspx?familyid=3755582A-A707-460A-BF21-1373316E13F0&displaylang=en
'http://support.microsoft.com/kb/315519
'http://blogs.msdn.com/oldnewthing/archive/2004/04/23/118893.aspx
'http://www.eggheadcafe.com/software/aspnet/32676356/toolbarwindow32-button-in.aspx
'http://msdn.microsoft.com/en-us/library/ms696152(VS.85).aspx
'http://msdn.microsoft.com/en-us/library/ms971323.aspx
'Caret Tracking
'http://www.geocities.com/krishnapg/EventTracking.html
'-------------------------------------------------------
'Visual Basic Related
'http://www.brainbell.com/tutors/Visual_Basic/Retrieving_Accessibility_Information.htm
'sample code with hooks to AA
'http://www.eggheadcafe.com/software/aspnet/31694003/please-help-ie-window-do.aspx
'http://www.jsware.net/jsware/vbcode.php5#acc
'Notes:
'Seems like in VB, there is no need to call VariantClear for variants defined as [out] in API.
Option Explicit
'references
'Accessibility - oleacc.dll
Private Declare Function AccessibleObjectFromEvent Lib "oleacc" (ByVal hwnd As Long, ByVal dwId As Long, ByVal dwChildId As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Private Declare Sub OutputDebugString Lib "kernel32" Alias "OutputDebugStringA" (ByVal lpOutputString As String)
Private Declare Function SetWinEventHook Lib "user32.dll" (ByVal eventMin As Long, ByVal eventMax As Long, ByVal hmodWinEventProc As Long, ByVal pfnWinEventProc As Long, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long
Private Declare Function UnhookWinEvent Lib "user32.dll" (ByVal lHandle As Long) As Long
'event constants
Private Const EVENT_OBJECT_CREATE = &H8000& ' // hwnd + ID + idChild is created item
Private Const EVENT_OBJECT_DESTROY = &H8001& '// hwnd + ID + idChild is destroyed item
Private Const EVENT_OBJECT_SHOW = &H8002& '// hwnd + ID + idChild is shown item
Private Const EVENT_OBJECT_HIDE = &H8003& '// hwnd + ID + idChild is hidden item
Private Const EVENT_OBJECT_FOCUS = &H8005& '// hwnd + ID + idChild is focused item
Private Const EVENT_OBJECT_LOCATIONCHANGE = &H800B& '// hwnd + ID + idChild is moved/sized item
Private Const WINEVENT_OUTOFCONTEXT = &H0& '// Events are ASYNC
Private Const WINEVENT_SKIPOWNPROCESS = &H2& '// Don't call back for events on installer's process
'class private stuff
Private m_hHook As Long
Private m_sMenuPath As String
Private Sub Class_Initialize()
Include "Common.MPopupMenuController"
m_hHook = SetWinEventHook(EVENT_OBJECT_FOCUS, EVENT_OBJECT_FOCUS, 0&, AddressOf MPopupMenuController.WinEventFunc, 0, 0, WINEVENT_SKIPOWNPROCESS)
End Sub
Private Sub Class_Terminate()
Dim lRet As Long
If m_hHook <> 0 Then
lRet = UnhookWinEvent(m_hHook)
End If
End Sub
Public Sub SelectMenu(sMenuPath As String)
MPopupMenuController.SelectMenu sMenuPath
End Sub
MPopupMenuController does the workhorse for this implementation, basically it houses the function when we set a hook to focus events. The module is also responsible for sending key sequences. See below for the code, save this as MPopupMenuController:
'------------------------------------------------------------------------------
' Developed by : Techno.Scavenger
' Licensed to : Mankind
' Date : 26Oct2008 @ 3:06 PM + 8 GMT (Sunday @home)
' Warranty
' THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
' “Techno.Scavenger” OR ANY OTHER CONTRIBUTOR BE LIABLE FOR ANY CLAIM,
' DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
' OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE
' USE OR OTHER DEALINGS IN THE SOFTWARE.
' Note:
' You can do whatever with this code
'------------------------------------------------------------------------------
'references
'Accessibility - oleacc.dll
Option Explicit
Private Declare Function AccessibleObjectFromEvent Lib "oleacc" (ByVal hwnd As Long, ByVal dwId As Long, ByVal dwChildId As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Sub OutputDebugString Lib "kernel32" Alias "OutputDebugStringA" (ByVal lpOutputString As String)
Private Declare Sub SleepEx Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)
'key constants
Private Const KEYEVENTF_KEYUP = 2
Private Const vbKeyControl = 17
Private Const vbKeyEscape = 27
'event constants
Private Const EVENT_OBJECT_CREATE = &H8000& '// hwnd + ID + idChild is created item
Private Const EVENT_OBJECT_DESTROY = &H8001& '// hwnd + ID + idChild is destroyed item
Private Const EVENT_OBJECT_SHOW = &H8002& '// hwnd + ID + idChild is shown item
Private Const EVENT_OBJECT_HIDE = &H8003& '// hwnd + ID + idChild is hidden item
Private Const EVENT_OBJECT_FOCUS = &H8005& '// hwnd + ID + idChild is focused item
Private Const EVENT_OBJECT_LOCATIONCHANGE = &H800B& '// hwnd + ID + idChild is moved/sized item
'private data
Private m_sMenuPath As String
Private m_sActiveItem As String
Public Function WinEventFunc(ByVal hHook As Long, ByVal lEvent As Long, ByVal hwnd As Long, ByVal idObject As Long, ByVal idChild As Long, ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As Long
Dim ObA As IAccessible
Dim lRet As Long
Dim v As Variant
Dim s As String, s1 As String, sName As String
Dim sTmp As String
On Error Resume Next
sTmp = "TS"
Select Case lEvent
'Case EVENT_OBJECT_CREATE, EVENT_OBJECT_DESTROY, EVENT_OBJECT_SHOW, EVENT_OBJECT_HIDE, EVENT_OBJECT_FOCUS, EVENT_OBJECT_LOCATIONCHANGE
Case EVENT_OBJECT_FOCUS
lRet = AccessibleObjectFromEvent(hwnd, idObject, idChild, ObA, v)
If lRet = 0 Then
sTmp = sTmp & ":Name:<" & ObA.accName(v)
sTmp = sTmp & ">:Description:< " & ObA.accDescription(v)
sTmp = sTmp & ">:Role<: " & ObA.accRole(v)
sTmp = sTmp & ">:State<: " & ObA.accState(v)
sTmp = sTmp & ">:menu<: " & m_sMenuPath
m_sActiveItem = ObA.accName(v)
End If
OutputDebugString sTmp
End Select
WinEventFunc = 0
End Function
Public Sub SelectMenu(sMenuPath As String)
m_sMenuPath = sMenuPath
PopupMenuEx sMenuPath
End Sub
Private Sub PopupMenuEx(sMenuPath As String)
Const MAX_LOOPS = 50
Dim vMenu As Variant
Dim iDx As Integer
Dim sMenuBookMark As String
Dim iTerminateCounter
vMenu = Split(sMenuPath, "~")
Call keybd_event(vbKeyControl, 0, 0, 0)
Call keybd_event(vbKeyEscape, 0, 0, 0)
' Release the two keys
Call keybd_event(vbKeyControl, 0, KEYEVENTF_KEYUP, 0)
Call keybd_event(vbKeyEscape, 0, KEYEVENTF_KEYUP, 0)
SleepEx 1000
For iDx = 0 To UBound(vMenu)
Do While m_sActiveItem <> vMenu(iDx)
OutputDebugString "TS: Sending DOWN key"
SendKeys "{DOWN}", True
SleepEx 1000
'set book on first loop thru menu indexes
If sMenuBookMark = "" Then
sMenuBookMark = m_sActiveItem
Else
'if we are here, then this must have been after one round
'we have come full circle, need to raise an error
If m_sActiveItem = sMenuBookMark Then
OutputDebugString "TS: We have come full circle, raising an error"
Include "Common.CustomErrorConstants"
Err.Raise CustomErrorConstants.vbErrMenuNotFound, "MPopupMenuController", "Menu was not found"
End If
End If
'another check if we have gone wild
iTerminateCounter = iTerminateCounter + 1
If iTerminateCounter >= MAX_LOOPS Then
OutputDebugString "TS:Max loops detected, raising an error"
Err.Raise CustomErrorConstants.vbErrMenuNotFound, "MPopupMenuController", "Menu was not found"
End If
Loop
'clear bookmark
sMenuBookMark = ""
'reset terminate marker
iTerminateCounter = 0
'move to next menu
OutputDebugString "TS:Sending RIGHT key"
SendKeys "{RIGHT}", True
Next
'assume we found the item, then hit on enter key
If vMenu(UBound(vMenu)) = m_sActiveItem Then
OutputDebugString "TS: We are about to run " & m_sActiveItem
SendKeys "~", True
Else
MsgBox "nah, not found"
End If
End Sub
Notice that we use custom error constant to raise an error to the system. The constants are defined in a module named CustomErrorConstants, see below for the code.
'------------------------------------------------------------------------------
' Developed by : Techno.Scavenger
' Licensed to : Mankind
' Date : 26Oct2008 @ 1:39 AM + 8 GMT (Sunday @home)
' Warranty
' THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
' “Techno.Scavenger” OR ANY OTHER CONTRIBUTOR BE LIABLE FOR ANY CLAIM,
' DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
' OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE
' USE OR OTHER DEALINGS IN THE SOFTWARE.
' Note:
' You can do whatever with this code
'------------------------------------------------------------------------------
Option Explicit
'Menu not found
Public Const vbErrMenuNotFound = vbObjectError + 4
Now the fun part, how to use? See below for a sample code.
'------------------------------------------------------------------------------
' Developed by : Techno.Scavenger
' Licensed to : Mankind
' Date : 26Oct2008 @ 3:06 PM + 8 GMT (Sunday @home)
' Warranty
' THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
' “Techno.Scavenger” OR ANY OTHER CONTRIBUTOR BE LIABLE FOR ANY CLAIM,
' DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
' OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE
' USE OR OTHER DEALINGS IN THE SOFTWARE.
' Note:
' You can do whatever with this code
'------------------------------------------------------------------------------
Option Explicit
Sub Main()
Window("Application=EXPLORER.EXE Caption=NewFolder").Attach
ListView("Index=1").Click 16, 295, tpMouseRight
Include "Common.CPopupMenuController"
Dim sm As CPopupMenuController
Set sm = New CPopupMenuController
sm.SelectMenu "New~Folder"
Set sm = Nothing
End Sub
Note that the above code is geared towards TestPartner 6.1.x. It is a functional test automation and a VBA host. This should work with minor modification to any VBA hosts like Excel, MSAcess ..etc.
Enjoy!
TS
