SHDocVw.ShellWindows stopped working on Vista

I have the following code to enumerate running instance of IE 7(not sure if this works with IE6).

Sub TestGetRunningIE()
    Dim sws As SHDocVw.ShellWindows
    Dim ie As SHDocVw.InternetExplorer
    
    Set sws = New SHDocVw.ShellWindows
    For Each ie In sws
        Debug.Print ie.Name
    Next
End Sub

For the above code to work, need to make a reference to shdocvw.dll, see below for the location:

When I moved this code in Vista SP1 Business it stopped working. Who would think that this is related to UAC :)... anyway just disable UAC and this code should work again. Note that on one of my machines it is working with UAC on :(....

See this post to disable UAC. This is only one of the methods to disable User Account Control.
~ts

Get treeview item information using VBA

Test Partner is quite flexible in handling treeview control. But there are times when you need to have a finer control of the object. The purpose of this blogpost is to document how to get treeview item information using Win32 api.

The code below is a class module that now supports getting the text of root and currently selected item. It also allows the user to check whether the item is expanded or not. See below for the code. For demonstration purposes, save this as TWin32TreeView class module under common project (I am referring to Test Partner here).

Below is a sample test script to use the class module. You can save this as "scratch" under common project.

Enjoy!

Note: For better result, use Notepad++ when copying source code from clipboard. The builtin Notepad.exe is not up to the job.

You may check latest copy from http://tscodesnippets.googlecode.com/svn/tpcodesnippets/trunk/ or browse source from svn repository here.

TechnoS

VBA: Using FileSystemObject to create a file

Sample code to create a file in VBA using FileSystemObject which is part of Microsoft Scripting Runtime. See this link on how to reference MSR.

Option Explicit

Sub TestMe()
    Dim fs As FileSystemObject
    Dim ts As TextStream
    
    Set fs = New FileSystemObject
    Set ts = fs.CreateTextFile("C:\tmp\file.txt", True)
    ts.WriteLine "Header1, Header2"
    ts.WriteLine "1," & CStr(DateTime.Now)
    ts.Close
    Set ts = Nothing
    Set fs = Nothing
End Sub

Referencing Microsoft Scripting Runtime for FileSystemObject class in VBA IDE

From Visual Basic for Applications IDE, do Tools | References... then look for Microsoft Scripting Runtime or browse for C:\Windows\System32\scrrun.dll.

Microsoft  Scripting Runtime provides the following classes:

• Dictionary
• Drive
• Drives
• Encoder
• File
• Files
• FileSystemObject
• Folder
• Folders
• TextStream

Controlling Popup menu using Accessibility API

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

Start Menu handler using Accessibility API

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 + 4

Now, 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 Sub

Notes: 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

Export TestPartner run into xml with xsl

TestPartner run results can be exported using command line, tpexport, or via File|Export from with TestPartner itself.

Another way of exporting run results is via TestPartner.TLB automation. The beauty with TestPartner.TLB is that you can export with it the xsl.

See below for the code.

Option Explicit
Sub TestTPResultDump()
    Dim t As New TPApp
    Dim pCount As Integer
    Dim p As Integer
    Dim sCount As Integer
    Dim sName As String
    Dim tp2 As TestPartner.TPProject2


    t.Login "admin", "admin", "TestPartner_SQL", 1

    pCount = t.Projects.Count

    For p = 1 To pCount
        If t.Projects.Item(p).Name = "ScratchProject" Then
            Debug.Print t.Projects.Item(p).Name
            Set tp2 = t.Projects.Item(p)
            Dim rc As Integer
            For rc = 1 To tp2.Results.Count
                If tp2.Results.Item(rc).Name = "scratch2" Then
                    Debug.Print tp2.Results.Item(rc).Description
                    Debug.Print tp2.Results.Item(rc).Name
                    Debug.Print tp2.Results.Item(rc).LastModifiedBy
                    Dim v As Long
                    v = tp2.Results.Item(rc).CurrentVersion
                    Dim rr As TestPartner.TPResult
                    Set rr = tp2.Results.Item(rc)
                    rr.Open (v)
                    Debug.Print rr.GetXML(v, v, "d:\test.xml")
                    Call rr.GetXML(v, 1, "D:\test.xml", "D:\test.xsl")
    
                    Dim sXLST As String
                    Dim fXLST As Scripting.File
                    
                    Debug.Print rr.GetXSLT(1, sXLST)
                    'Debug.Print sXLST
                    Dim fso As Scripting.FileSystemObject
                    Dim ts As Scripting.TextStream
                    Set fso = New Scripting.FileSystemObject
                    Set ts = fso.OpenTextFile("D:\test.xsl", ForWriting, True, TristateTrue)
                    ts.Write sXLST
                    ts.Close
                    Set ts = Nothing
                    Set fso = Nothing
                End If
            Next rc
            'tp2.Results.Count
        End If

    Next p
End Sub

Note that you need reference to TestPartner(TestPartner.TLB) and Microsoft Scripting Runtime for the above code snippets to work.

See below for the location of the type library:

~ts

Handle popup menus manually in TestPartner

One of the areas where TestPartner 6.1.x is challenged in controlling application under test (AUT) is Popup Menus. It handles it one time but sometimes it complains that the menu is not detected but it is clearly infront of the screen. Though it is working ~80% of the time but Murphy's law has it that if anything can go wrong, it will. What I have come up so far is to handle popup menus manually. See below for the code, so far it seems to meet my needs.

Option Explicit
Private Declare Function SetCursorPos Lib "user32" _
    (ByVal x As Long, ByVal y As Long) As Long
Sub Main()
    'open Windows Explorer in "My Computer"
    Window("Desktop Window").Attach
        ListView("Index=1").Select "CD Drive (E:)", tpMouseRight
    
    PopupMenuEx2 "Properties"

    Window("Application=Explorer.exe Classname='#32770'").Attach
        Button("Caption=OK").Click



End Sub
Private Function PopupMenuEx2(sMenuPath As String) As Boolean
    Dim iMenuCount As Integer
    Dim sMenuSplit As Variant
    Dim iMenuPos As Integer
    
    SetCursorPos 1, 1
    Window.MouseMove 1, 1
    
    'Note that this is important. This is to minimize code in SelectMenuItem
    SendKeys "{DOWN}", True
    sMenuSplit = Split(sMenuPath, "~")
    For iMenuCount = 0 To UBound(sMenuSplit)
        SelectMenuItem sMenuSplit(iMenuCount), iMenuCount > 0
        
        If iMenuCount = UBound(sMenuSplit) Then
            SendKeys "{ENTER}", True
            Exit For
        Else
            SendKeys "{RIGHT}", True
        End If
    Next
End Function

Private Function SelectMenuItem(ByVal sMenuStr As String, isSubMenu As Boolean) As Integer
    Dim mnu As TMenu
    Dim ti As TMenuItem
    Dim i As Integer
    Dim sAttachName As String
    Const DELAY = 100
    
    sAttachName = Window.Application
    sAttachName = "Application=" & sAttachName & " ClassName='#32768'"
    If isSubMenu = False Then
        Set mnu = Window(sAttachName).GetMenu(tpPopupMenu)
    Else
        Set mnu = Window(sAttachName).GetMenu(tpMenu)
    End If
    For i = 1 To mnu.Count
        Set ti = mnu.GetItem(i)
        If ti.Text = sMenuStr Then
            Sleep DELAY, tpPauseMilliSeconds
            Exit Function
        End If
        If Not (ti.IsSeparator) Then
            Sleep DELAY, tpPauseMilliSeconds
            SendKeys "{DOWN}", True
        End If
    Next
End Function

~ts

The file is not a valid compound file opening data link file

If you get this message when opening an ADO connection using Data Link File (.udl)  then this may mean that your .udl file was saved as ANSI. To fix this save .udl file as Unicode  BOM.

~ts~

Open any document in IFix via shell

Below is a sample procedure to open a text in IFix.

Private Sub CommandButton1_Click()
    Dim ret As Long
    Dim hwnd As Long

    hwnd = FindWindow(vbNullString, Application.Caption)
    ret = shellExecute(hwnd, "Open", "c:\DVPendingFileRenameOp.log", vbNullString, vbNullString, 4)
End Sub

Note: Application is an IFix global variable.