The code below demonstrates how to run an application from Start menu using accessibility API in TestPartner making use of VBA.
For this exercise, we will use Test Script, Class Module and Module. The original intent was to have the functionality built into class module and instantiate it in Test Script. But AddressOf operator does not work inside a class module in VBA hence using Module.
Anyway, first let us define the class module. For this exercise name it CStartMenuController. See below for the code (save this as CStartMenuController):
'------------------------------------------------------------------------------
' Develop 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
'------------------------------------------------------------------------------
'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.MStartMenuController"
m_hHook = SetWinEventHook(EVENT_OBJECT_FOCUS, EVENT_OBJECT_FOCUS, 0&, AddressOf MStartMenuController.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)
MStartMenuController.SelectMenu sMenuPath
End Sub
As mentioned above, we need a module to house the function we supply to SetWinEventHook. And this is also where most of the action happens. See below for the code, save this as MStartMenuController:
'------------------------------------------------------------------------------
' Develop 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
'------------------------------------------------------------------------------
'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 = "YH"
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 Function SetMenuPath(sMenuPath As String) As Boolean m_sMenuPath = sMenuPath End Function Public Sub SelectMenu(sMenuPath As String) m_sMenuPath = sMenuPath StartMenuEx sMenuPath End Sub Private Sub StartMenuEx(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 "YH: 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 "YH: We have come full circle, raising an error"
Include "Common.CustomErrorConstants"
Err.Raise CustomErrorConstants.vbErrMenuNotFound, "MStartMenuController", "Menu was not found"
End If
End If
'another check if we have gone wild
iTerminateCounter = iTerminateCounter + 1
If iTerminateCounter >= MAX_LOOPS Then
OutputDebugString "YH:Max loops detected, raising an error"
Err.Raise CustomErrorConstants.vbErrMenuNotFound, "MStartMenuController", "Menu was not found"
End If
Loop
'clear bookmark
sMenuBookMark = ""
'reset terminate marker
iTerminateCounter = 0
'move to next menu
OutputDebugString "YH: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 "YH: We are about to run " & m_sActiveItem
SendKeys "~", True
Else
MsgBox "nah, not found"
End If
End Sub
To make the code a little modular, we have separated custom error constants for use when raising our custom Error. See below for constant definitions and save this as CustomErrorConstants.
'------------------------------------------------------------------------------ ' 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 + 4Now, how do we use it? We it is quite easy actually. See below for a sample code that runs HyperTerminal. Save it as scratch or whatever suites you best.
'------------------------------------------------------------------------------ ' Develop 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 Sub Main() Include "Common.CStartMenuController" Dim sm As CStartMenuController Set sm = New CStartMenuController sm.SelectMenu "All Programs~Accessories~Communications~HyperTerminal" Set sm = Nothing End SubNotes: This code is targeted for TestPartner 6.1.x. This should work with any VBA host but you need to adjust a few things. This is also inteneded to work only with Start Menu set to Windows XP style. It should be easy to adapt this for both classic and XP start menu. Enjoy! TS
Comments