NonSoft - 全てのウィンドウとコントロールの情報を表示するサンプル(VB6)

全てのウィンドウとコントロールの情報を表示するサンプル(VB6)

サンプルソース

＜このサンプルの概要＞
全てのウィンドウとコントロールの情報を表示するサンプルソースを作ってみました。
VB6のフォームにTreeViewを1つ追加してお試しください。
ステータスバー(msctls_statusbar32)の各パートの文字列を取得する関数もありますが、
この関数はVB6のデバッグでは動きません。EXEを作ってお試しください。

VB.NET版はこちらです。
全てのウィンドウとコントロールの情報を表示するサンプル(VB.NET)

本サンプルのキーワードは以下のAPIです。
(1)EnumWindows
(2)EnumChildWindows
(3)GetClassName
(4)SendMessage
(5)GetWindowThreadProcessId
(6)OpenProcess
(7)CloseHandle
(8)VirtualAllocEx
(9)VirtualFreeEx
(10)ReadProcessMemory
(11)WriteProcessMemory

★標準モジュール(Module1.bas)

Private Const SB_GETPARTS = &H406
Private Const SB_GETTEXT = &H402
Private Const SB_GETTEXTLENGTH = &H403
Private Const PROCESS_VM_OPERATION = &H8&
Private Const PROCESS_VM_READ = &H10&
Private Const PROCESS_VM_WRITE = &H20&
Private Const MEM_RESERVE = &H2000&
Private Const MEM_COMMIT = &H1000&
Private Const MEM_RELEASE = &H8000&
Private Const PAGE_READWRITE = &H4&
Private Const WM_GETTEXT = &HD
Private Declare Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As Long, lParam As Any) As Long
Private Declare Function EnumChildWindows Lib "user32" (ByVal hwndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lplngProcessId As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal lngProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function VirtualAllocEx Lib "kernel32.dll" (ByVal lngProcessH 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 lngProcessH As Long, ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Integer
Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal lngProcessH As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal lngProcessH As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long

' コントロール毎の情報を設定するコレクション
Private colWindows As New Collection

' ウィンドウとコントロールを全て取得
Public Function GetAllWindows() As Collection
    On Error Resume Next
    Dim i As Long
    Dim lngRet As Long
    
    ' コントロール毎の情報を設定するコレクション生成
    Set colWindows = New Collection
    Set GetAllWindows = colWindows
    
    ' トップレベルウィンドウを全て取得
    lngRet = EnumWindows(AddressOf EnumWindowsProc, 0)
    
    ' 親ウィンドウに属するコントロールを全て取得
    For i = 1 To colWindows.Count
        lngRet = EnumChildWindows(colWindows.Item(i).Item(1)(0), _
                         AddressOf EnumChildWindowsProc, i)
    Next i
End Function

' トップレベルウィンドウを全て取得
Public Function EnumWindowsProc(ByVal hWnd As Long, lParam As Long) As Long
    On Error Resume Next
    Dim lngRet As Long
    Dim strClassB As String * 255, strTitleB As String * 255
    Dim strClass As String, strTitle As String

    ' クラス名取得
    lngRet = GetClassName(hWnd, strClassB, 255)
    strClass = StripNulls(strClassB)
    
    ' ウィンドウのタイトル取得
    lngRet = SendMessage(hWnd, WM_GETTEXT, 255, ByVal strTitleB)
    strTitle = StripNulls(strTitleB)
    
    ' 取得した情報を配列に設定
    Dim strDa(2) As Variant
    strDa(0) = hWnd
    strDa(1) = strClass
    strDa(2) = strTitle
    
    ' 取得した情報をコレクションに設定
    Dim colDa As New Collection
    colDa.Add strDa
    
    ' トップレベルウィンドウ毎のコレクションに追加
    colWindows.Add colDa
    
    ' リターン
    EnumWindowsProc = 1
End Function

' 指定された親ウィンドウに属するコントロールを全て取得
Function EnumChildWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
    On Error Resume Next
    Dim lngRet As Long
    Dim strClassB As String * 255, strTitleB As String * 255
    Dim strClass As String, strTitle As String

    ' クラス名取得
    lngRet = GetClassName(hWnd, strClassB, 255)
    strClass = StripNulls(strClassB)
    
    ' ウィンドウのタイトル取得
    lngRet = SendMessage(hWnd, WM_GETTEXT, 255, ByVal strTitleB)
    strTitle = StripNulls(strTitleB)
    
    ' クラス名毎の特殊処理
    If strClass = "msctls_statusbar32" Then
        strTitle = strTitle & "(" & GetStatusBarText(hWnd) & ")"
    End If
    
    ' 取得した情報を配列に設定
    Dim strDa(2) As Variant
    strDa(0) = hWnd
    strDa(1) = strClass
    strDa(2) = strTitle
    
    ' コントロール毎のコレクションに追加
    colWindows.Item(lParam).Add strDa
    
    ' リターン
    EnumChildWindowsProc = 1
End Function

' ステータスバーの文字列を全て取得
Public Function GetStatusBarText(hWnd As Long) As String
    On Error Resume Next
    Dim lngLen As Long
    Dim lngPart As Long
    Dim lngNo As Long
    Dim strTmpB As String * 255
    Dim strTmp As String
    
    ' ステータスバーのパート数を取得
    lngPart = SendMessage(hWnd, SB_GETPARTS, 0, 0)
    
    ' ステータスバーの各パートの文字列を取得
    For lngNo = 0 To lngPart - 1
        ' ステータスバーの各パートの文字列の長さを取得
        lngLen = SendMessage(hWnd, SB_GETTEXTLENGTH, ByVal lngNo, ByVal 0)
        lngLen = (lngLen And &HFFFF&)
        
        ' 共有メモリを使用しステータスバーの各パートの文字列を取得
        If lngLen > 0 Then
            Call SendMessageByVAEString(hWnd, SB_GETTEXT, lngNo, strTmpB)
            strTmp = StripNulls(strTmpB)
            GetStatusBarText = GetStatusBarText & strTmp
        End If
        
        ' 各パートをカンマ区切りの文字列にする
        If lngNo < lngPart - 1 Then
            GetStatusBarText = GetStatusBarText & ","
        End If
    Next lngNo
End Function

' 共有メモリを使用しSendMessageを発行／情報取得
Public Function SendMessageByVAEString(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As String) As Long
    On Error Resume Next
    Dim lngRet As Long
    Dim lngProcessId As Long
    Dim lngProcessH As Long
    Dim lngVirtual As Long
    Dim bytBuf() As Byte
    lParam = String(Len(lParam), 0)
    bytBuf = StrConv(lParam, vbFromUnicode)

    ' 指定されたコントロールが存在するプロセスのIDを取得
    Call GetWindowThreadProcessId(hWnd, lngProcessId)

    ' プロセスのオープン
    lngRet = OpenProcess(PROCESS_VM_OPERATION Or PROCESS_VM_READ Or _
                         PROCESS_VM_WRITE, False, lngProcessId)
    If lngRet = 0 Then
        SendMessageByVAEString = 0
        Exit Function
    End If
    lngProcessH = lngRet
    
    ' プロセス内に共有メモリ確保
    lngRet = VirtualAllocEx(lngProcessH, ByVal 0, UBound(bytBuf) + 1, _
                            MEM_RESERVE Or MEM_COMMIT, PAGE_READWRITE)
    If lngRet = 0 Then
        SendMessageByVAEString = 0
        Call CloseHandle(lngProcessH)
        Exit Function
    End If
    
    lngVirtual = lngRet
    
    ' 共有メモリ初期化
    lngRet = WriteProcessMemory(lngProcessH, lngVirtual, bytBuf(0), UBound(bytBuf) + 1, ByVal 0)
    If lngRet = 0 Then
        SendMessageByVAEString = 0
        Call VirtualFreeEx(lngProcessH, lngVirtual, 0, MEM_RELEASE)
        Call CloseHandle(lngProcessH)
        Exit Function
    End If
    
    ' SendMessage発行
    SendMessageByVAEString = SendMessage(hWnd, wMsg, wParam, lngVirtual)
            
    ' 共有メモリから情報取得
    lngRet = ReadProcessMemory(lngProcessH, lngVirtual, bytBuf(0), UBound(bytBuf) + 1, ByVal 0)
    If lngRet = 0 Then
        SendMessageByVAEString = 0
        Call VirtualFreeEx(lngProcessH, lngVirtual, 0, MEM_RELEASE)
        Call CloseHandle(lngProcessH)
        Exit Function
    End If

    ' 共有メモリから取得した文字列をユニコード変換
    lParam = StrConv(bytBuf, vbUnicode)

    ' 共有メモリ解放
    lngRet = VirtualFreeEx(lngProcessH, lngVirtual, 0, MEM_RELEASE)
    If lngRet = 0 Then
        SendMessageByVAEString = 0
    End If
    
    ' プロセスのクローズ
    lngRet = CloseHandle(lngProcessH)
    If lngRet = 0 Then
        SendMessageByVAEString = 0
    End If
End Function

' 文字列からＮＵＬＬ文字以降をカット
Public Function StripNulls(ByVal strOrg As String) As String
    On Error Resume Next
    If (InStr(strOrg, Chr(0)) > 0) Then
        strOrg = Left(strOrg, InStr(strOrg, Chr(0)) - 1)
    End If
    StripNulls = strOrg
End Function

★フォームモジュール(Form1.frm)

' フォームロード
Private Sub Form_Load()
    Dim i As Long
    Dim j As Long
    Dim strClass As String
    Dim strTitle As String
    Dim strSpace As String
    
    ' ウィンドウとコントロールの全ての情報を取得
    Dim colWindows As Collection
    Set colWindows = GetAllWindows()
    
    ' 親ウィンドウ毎のコレクションループ
    For i = 1 To colWindows.Count
        ' 子コントロール毎のコレクション取得
        Dim colChilds As Collection
        Set colChilds = colWindows.Item(i)
        
        'If colChilds.Count >= 1 Then        ' 全ての親ウィンドウを対象
        If colChilds.Count > 1 Then         ' 子コントロールを持つ物のみ対象
            ' 子コントロール毎のコレクションループ
            For j = 1 To colChilds.Count
                strSpace = StrConv(String(50, " "), vbFromUnicode)
                
                ' コレクションからクラス名取得
                strClass = StrConv(colChilds.Item(j)(1), vbFromUnicode)
                If LenB(strClass) < 30 Then
                    strClass = LeftB$(strClass & strSpace, 30)
                End If
                strClass = StrConv(strClass, vbUnicode)
                
                ' コレクションから文字列取得
                strTitle = StrConv(colChilds.Item(j)(2), vbFromUnicode)
                If LenB(strTitle) < 50 Then
                    strTitle = LeftB$(strTitle & strSpace, 50)
                End If
                strTitle = StrConv(strTitle, vbUnicode)
        
                If j = 1 Then
                    ' 親ウィンドウの情報をツリービューへ追加
                    Call TreeView1.Nodes.Add( _
                        , , "R" & _
                        Right$("00000000" & Hex(colChilds.Item(j)(0)), 8), _
                        Right$("00000000" & Hex(colChilds.Item(j)(0)), 8) & " - " & _
                        strClass & " - " & strTitle)
                Else
                    ' 子コントロールの情報をツリービューへ追加
                    Call TreeView1.Nodes.Add( _
                        "R" & Right$("00000000" & Hex(colChilds.Item(1)(0)), 8), _
                        tvwChild, "C" & _
                        Right$("00000000" & Hex(colChilds.Item(j)(0)), 8), _
                        Right$("00000000" & Hex(colChilds.Item(j)(0)), 8) & " - " & _
                        strClass & " - " & strTitle)
                End If
            Next j
        End If
    Next i
End Sub

' フォームリサイズ
Private Sub Form_Resize()
    ' ツリービューの幅設定
    If Me.ScaleWidth - (TreeView1.Left * 2) > 0 Then
        TreeView1.Width = Me.ScaleWidth - (TreeView1.Left * 2)
    End If
    ' ツリービューの高さ設定
    If Me.ScaleHeight - (TreeView1.Top * 2) > 0 Then
        TreeView1.Height = Me.ScaleHeight - (TreeView1.Top * 2)
    End If
End Sub

トップページ

ダウンロード

サンプルソース

ち～な～み～に～

その他のおすすめソフト