Friday, July 25, 2008

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).

Option Explicit

'References:
'http://msdn.microsoft.com/en-us/library/bb759988(VS.85).aspx
'http://www.xtremevbtalk.com/showthread.php?t=45515
'http://www.tek-tips.com/viewthread.cfm?qid=344761&page=8
'Get items across process boundaries
'http://www.codeproject.com/KB/threads/int64_memsteal.aspx?fid=29535&df=90&mpp=25&noise=3&sort=Position&view=Quick&select=2558283&fr=26
'http://www.autoitscript.com/forum/lofiversion/index.php?t9988.html
'Getting text from GetLastError
'http://support.microsoft.com/kb/186063
'How To List Running Processes
'http://support.microsoft.com/kb/187913
'problem using LVM_SETTEXTBKCOLOR to change color listview text
'http://www.programmersheaven.com/mb/VBasic/340733/340733/ReadMessage.aspx
'GetCommandLine win32 function for VB/VBA
'http://www.motobit.com/tips/detpg_vba-getcommandline/


Private Const TVGN_ROOT As Long = &H0
Private Const TVGN_CARET As Long = &H9

'// TreeView messages
Private Const TV_FIRST As Long = &H1100
Private Const TVM_GETCOUNT As Long = (TV_FIRST + 5)
Private Const TVM_GETNEXTITEM As Long = (TV_FIRST + 10)
Private Const TVM_SELECTITEM As Long = (TV_FIRST + 11)
Private Const TVM_GETITEM As Long = (TV_FIRST + 12) 'this is assuming non-UNICODE
Private Const TVM_ENSUREVISIBLE As Long = (TV_FIRST + 20)
Private Const TVM_GETITEMSTATE As Long = (TV_FIRST + 39)
'TreeView item mask
Private Const TVIF_TEXT = &H1
Private Const TVIF_STATE = &H8
Private Const TVIF_HANDLE = &H10
Private Const TVIF_CHILDREN = &H40

'Treeview statemask
Private Const TVIS_EXPANDED = &H20


Private Const MAXTEXTLEN = 50 'max length per item in tree view

Private m_hwnd As Long

'//process related
Private Const PROCESS_VM_OPERATION As Integer = &H8
Private Const PROCESS_VM_READ As Integer = &H10
Private Const PROCESS_VM_WRITE As Integer = &H20
Private Const PROCESS_QUERY_INFORMATION As Integer = &H400

Private Const MEM_COMMIT = &H1000&
Private Const MEM_RESERVE = &H2000&
Private Const MEM_RELEASE = &H8000&

Private Const PAGE_READWRITE = &H4&

Private Type TVITEM 'was TV_ITEM
    mask As Long
    hItem As Long
    state As Long
    stateMask As Long
    pszText As Long 'pointer to string
    cchTextMax As Long
    iImage As Long
    iSelectedImage As Long
    cChildren As Long
    lParam As Long
End Type

Private Type TVITEMEX
    mask As Long
    hItem As Long
    state As Long
    stateMask As Long
    pszText As Long 'pointer to string
    cchTextMax As Long
    iImage As Long
    iSelectedImage As Long
    cChildren As Long
    lParam As Long
    iIntegral As Long
    #If (WIN32_IE >= &H600) Then
    uStateEx As Long
    hwnd As Long
    iExpandedImage As Long
    #End If
End Type

Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000

Private Declare Function FormatMessage Lib "kernel32" Alias _
    "FormatMessageA" (ByVal dwFlags As Long, lpSource As Long, _
    ByVal dwMessageId As Long, ByVal dwLanguageId As Long, _
    ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Any) _
    As Long
Private Declare Function SendMessageAny Lib "user32" _
    Alias "SendMessageA" _
    (ByVal hwnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Any, _
    lParam As Any) As Long

Private Declare Function GetWindowThreadProcessId Lib "user32" _
    (ByVal hwnd As Long, lpdwprocessid As Long) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" _
    (ByVal dwAccess As Long, _
    ByVal fInherit As Integer, _
    ByVal hObject As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" _
    (ByVal hObject As Long) As Long
Private Declare Function VirtualAllocEx Lib "kernel32" _
    (ByVal hProcess As Long, lpAddress As Any, _
    ByVal dwSize As Long, _
    ByVal flAllocationType As Long, _
    ByVal flProtect As Long) As Long
Private Declare Function VirtualFreeEx Lib "kernel32" _
    (ByVal hProcess As Long, _
    lpAddress As Any, _
    ByVal dwSize As Long, _
    ByVal dwFreeType As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" _
    (ByVal hProcess As Long, _
    lpBaseAddress As Any, _
    lpBuffer As Any, _
    ByVal nSize As Long, _
    lpNumberOfBytesWritten As Long) As Long
Private Declare Function ReadProcessMemory Lib "kernel32" _
    (ByVal hProcess As Long, _
    lpBaseAddress As Any, _
    lpBuffer As Any, _
    ByVal nSize As Long, _
    lpNumberOfBytesWritten As Long) As Long
Private Declare Function lstrcpyn_long_string Lib "kernel32" _
    Alias "lstrcpynA" (ByVal DestString As String, _
    ByVal SourcePointer As Long, _
    ByVal MaxLen As Long) As Long
Private Declare Function lstrlen_long Lib "kernel32" _
    Alias "lstrlenA" (ByVal SourcePointer As Long) As Long

'this black magic functions are not yet being used
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapAlloc Lib "kernel32" _
    (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" _
    (ByVal hHeap As Long, _
    ByVal dwFlags As Long, _
    lpMem As Any) As Long
Private Declare Sub CopyMemoryWrite Lib "kernel32" _
    Alias "RtlMoveMemory" _
    (ByVal Destination As Long, _
    Source As Any, ByVal Length As Long)

Private Function MessageText(lCode As Long) As String
    Dim sRtrnCode As String
    Dim lret As Long
    
    sRtrnCode = Space$(256)
    lret = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0&, lCode, 0&, _
    sRtrnCode, 256&, 0&)
    If lret > 0 Then
        MessageText = Left(sRtrnCode, lret)
    Else
        MessageText = "Error not found."
    End If
End Function

Public Property Let Handle(l_hwnd As Long)
    m_hwnd = l_hwnd
    OutputDebugString "YH:- Handle: " & CStr(m_hwnd)
End Property


Public Property Get Count() As Long
    Dim lResult As Long
    lResult = SendMessage(m_hwnd, TVM_GETCOUNT, 0, 0)
    Count = lResult
End Property

Public Function MoveToRoot()
    Dim lResult As Long
    lResult = SendMessageAny(m_hwnd, TVM_GETNEXTITEM, TVGN_ROOT, 0&)
    'Note: Very important
    'Since lResult is already a pointer to a memory
    'we need to pass the value into the stack as is, not the address hence using ByVal instead of ByRef
    Call SendMessageAny(m_hwnd, TVM_SELECTITEM, TVGN_CARET, ByVal lResult)
End Function

Public Function GetRootItemText() As String 'TVITEM
    Dim pid As Long
    Dim process As Long
    Dim tv_item As TVITEM
    Dim ptv_item As Long 'pointer to tv_item
    Dim pitemsz As Long 'Pointer to pz
    Dim pitem_root As Long 'pointer to tv_item for the root node
    Dim sRet As String

    Call GetWindowThreadProcessId(m_hwnd, pid)
    process = OpenProcess(PROCESS_VM_OPERATION Or PROCESS_VM_READ Or PROCESS_VM_WRITE Or PROCESS_QUERY_INFORMATION, 0, pid)
    
    If process > 0 Then
        ptv_item = VirtualAllocEx(process, 0, LenB(tv_item), MEM_COMMIT, PAGE_READWRITE)
        pitemsz = VirtualAllocEx(process, 0, MAXTEXTLEN, MEM_COMMIT, PAGE_READWRITE)
        pitem_root = SendMessageAny(m_hwnd, TVM_GETNEXTITEM, TVGN_ROOT, 0&)
        
        If pitem_root <> 0 Then
            tv_item.cchTextMax = MAXTEXTLEN
            tv_item.hItem = pitem_root
            'tv_item.mask = TVIF_TEXT Or TVIF_CHILDREN
            tv_item.mask = TVIF_TEXT Or TVIF_HANDLE
            tv_item.pszText = pitemsz
            
            Dim lpWritten As Long
            Dim lret As Long
            
            lret = WriteProcessMemory(process, ByVal ptv_item, tv_item, LenB(tv_item), lpWritten)
            If lret = 0 Then
                OutputDebugString "YH: -o- WriteProcessMemory returned 0 "
            End If
    
            Call SendMessageAny(m_hwnd, TVM_GETITEM, 0&, ByVal ptv_item)
            
            Dim buf() As Byte
            ReDim buf(MAXTEXTLEN)
            lret = ReadProcessMemory(process, ByVal pitemsz, buf(0), MAXTEXTLEN, lpWritten)
            OutputDebugString "YH: -o- lpwritten > " & CStr(lpWritten)
            
            Dim index As Long
            Dim tmpstring As String
            For index = LBound(buf) To UBound(buf)
            If Chr(buf(index)) = vbNullChar Then Exit For
            tmpstring = tmpstring & Chr(buf(index))
            Next index
            sRet = tmpstring
            
            OutputDebugString "YH: -o- " & tmpstring
        End If
    End If
    
    VirtualFreeEx process, ByVal pitemsz, MAXTEXTLEN, MEM_RELEASE
    VirtualFreeEx process, ByVal tv_item, LenB(tv_item), MEM_RELEASE
    CloseHandle process
    GetRootItemText = sRet
End Function
'Note: Use TVGN_CARET flag of TVM_GETNEXTITEM to get the currently selected item
Public Function GetSelectedItemText() As String
    Dim pid As Long
    Dim process As Long
    Dim tv_item As TVITEM
    Dim ptv_item As Long 'pointer to tv_item
    Dim pitemsz As Long 'Pointer to pz
    Dim pitem_selected As Long 'pointer to tv_item for the selected item
    Dim sRet As String 'return string
    
    Call GetWindowThreadProcessId(m_hwnd, pid)
    process = OpenProcess(PROCESS_VM_OPERATION Or PROCESS_VM_READ Or PROCESS_VM_WRITE Or PROCESS_QUERY_INFORMATION, 0, pid)
    
    If process > 0 Then
        ptv_item = VirtualAllocEx(process, 0, LenB(tv_item), MEM_COMMIT, PAGE_READWRITE)
        pitemsz = VirtualAllocEx(process, 0, MAXTEXTLEN, MEM_COMMIT, PAGE_READWRITE)
        'get pointer to item object
        pitem_selected = SendMessageAny(m_hwnd, TVM_GETNEXTITEM, TVGN_CARET, 0&)
        If pitem_selected <> 0 Then
            tv_item.cchTextMax = MAXTEXTLEN
            tv_item.hItem = pitem_selected
            tv_item.mask = TVIF_TEXT Or TVIF_HANDLE
            tv_item.pszText = pitemsz

            Dim lpWritten As Long
            Dim lret As Long

            lret = WriteProcessMemory(process, ByVal ptv_item, tv_item, LenB(tv_item), lpWritten)
            If lret = 0 Then
                OutputDebugString "YH: -o- WriteProcessMemory returned 0 "
            End If
            'Now get ptv_item populated with data
            Call SendMessageAny(m_hwnd, TVM_GETITEM, 0&, ByVal ptv_item)

            Dim buf() As Byte
            ReDim buf(MAXTEXTLEN)
            lret = ReadProcessMemory(process, ByVal pitemsz, buf(0), MAXTEXTLEN, lpWritten)
            OutputDebugString "YH: -o- lpwritten > " & CStr(lpWritten)

            Dim index As Long
            Dim tmpstring As String
            For index = LBound(buf) To UBound(buf)
                If Chr(buf(index)) = vbNullChar Then Exit For
                tmpstring = tmpstring & Chr(buf(index))
            Next index
            sRet = tmpstring

            OutputDebugString "YH: -o- " & tmpstring
        End If
    End If

    VirtualFreeEx process, ByVal pitemsz, MAXTEXTLEN, MEM_RELEASE
    VirtualFreeEx process, ByVal tv_item, LenB(tv_item), MEM_RELEASE
    CloseHandle process
    GetSelectedItemText = sRet
End Function
'Note: Use TVM_GETITEMSTATE message with stateMask set to TVIS_EXPANDED
Public Function IsSelectedItemExpanded() As Boolean
    Dim pitem_selected As Long 'pointer to tv_item for the selected item
    Dim bRet As Boolean
    
    pitem_selected = SendMessageAny(m_hwnd, TVM_GETNEXTITEM, TVGN_CARET, 0&)
    'Now get ptv_item populated with data, get the state of the item
    Dim lItemState As Long
    'lItemState = SendMessageAny(m_hwnd, TVM_GETITEMSTATE, ByVal ptv_item, TVIS_EXPANDED)
    lItemState = SendMessageAny(m_hwnd, TVM_GETITEMSTATE, ByVal pitem_selected, TVIS_EXPANDED)
    If (lItemState And TVIS_EXPANDED) = TVIS_EXPANDED Then
        bRet = True
    Else
        bRet = False
    End If
    IsSelectedItemExpanded = bRet
End Function

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

Option Explicit

Sub Main()
    Include "Common.TWin32TreeView"
    Dim wtv As TWin32TreeView
    
    'Window("Desktop Window").Attach
    Window("Application=Explorer.exe ClassName=CabinetWClass TypeName=Window").Attach
    
    Set wtv = New TWin32TreeView
    wtv.Handle = TreeView("Index=1").hwnd
    Dim sMsg As String
    sMsg = "Root item is " & wtv.GetRootItemText
    sMsg = sMsg & vbCrLf & "Selected item is : " & wtv.GetSelectedItemText
    MsgBox sMsg
    
    If wtv.IsSelectedItemExpanded Then
        MsgBox "selected node is expanded"
    Else
        MsgBox "it is not yet expanded"
    End If

End Sub
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

6 comments:

Anonymous said...
This comment has been removed by a blog administrator.
Anonymous said...

Very nicce!

Techno Scavenger said...

You are welcome, thanks for the comment.

Anonymous said...

hi, new to the site, thanks.

Anonymous said...

just dropping by to say hi

Anonymous said...

Excellent!!!