[ExcelVBA] ウィンドウハンドルを取得する - WindowsAPI

>Blog Top Page >[ExcelVBA] Top Page >[ExcelVBA] ExcelVBA ALL >[ExcelVBA] AdventCalendar

アドベントカレンダー 14日目

クラス名がわかっていれば、FindWindow関数でも使ってハンドル取得すりゃいい話なんですが
わからん時は、いちいちEnumWindows関数で全ハンドル取得してウィンドウ名を取得して
該当するハンドルを見つけりゃいいわけですが、ちょいとめんどくさいから関数作ってしまいましょ。

関数の仕様としては、欲しいウィンドウハンドルの名前を指定します。
指定の仕方は正規表現で指定できます。
返り値は、DictionaryのObjectが返ってきます。

Dictionaryの構造は、ハンドルをキーに値にDicitionaryを持ちます。
そのDicitionaryは
ClassName という文字列をキーにクラス名を値に
WIndowName という文字列をキーにウィンドウ名を値に持ちます。

(Dictionary) = Hwnd => (Dictionary)
                                       "ClassName"     => [クラス名],
                                       "WIndowName" => [ウィンドウ名]
 

コードは以下の通りです。

view plainprint?

1. Option Explicit  
2.   
3. Private Declare Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As Long, lParam As Long) As Long  
4. Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _  
5.        (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long  
6. Private Declare Function SendMessageStr Lib "user32.dll" Alias "SendMessageA" _  
7.        (ByVal hwnd As Long, ByVal MSG As Long, _  
8.         ByVal wParam As Long, ByVal lParam As String) As Long  
9.   
10. Private Const WM_GETTEXT = &HD  
11. Private Const WM_GETTEXTLENGTH = &HE  
12.   
13. Private DicHwnd As Object  
14. Private RegWindowTitle As Object  
15.   
16. Public Function GetHwnd(ByVal RegPattern As String) As Object  
17.     Dim Ret As Long  
18.       
19.     'FileNameに一致するハンドルをキーにタイトルを値に格納する変数  
20.     'CallBack関数とやりとりするのでGlobal領域で宣言しておく  
21.     Set DicHwnd = CreateObject("Scripting.Dictionary")  
22.     Set RegWindowTitle = CreateObject("VBScript.RegExp")  
23.       
24.     RegWindowTitle.Global = False  
25.     RegWindowTitle.IgnoreCase = True  
26.     RegWindowTitle.Pattern = EscapeRegString(RegPattern)  
27.   
28.     '必ずエラーになるので止まらないよう処理しておく  
29.     On Error Resume Next  
30.     Ret = EnumWindows(AddressOf EnumWindowsProc, 0)  
31.     On Error GoTo 0 '問題の部分を過ぎたのでエラー処理をもとに戻す  
32.       
33.     Set GetHwnd = DicHwnd  
34.     Set DicHwnd = Nothing  
35. End Function  
36.   
37. Private Function EnumWindowsProc(ByVal hwnd As Long) As Long  
38.     Dim ClassName   As String  
39.     Dim length      As Integer  
40.     Dim Ret         As Integer  
41.     Dim str         As String  
42.     Dim WindowTitle As String  
43.       
44.     EnumWindowsProc = 1  
45.       
46.     'ハンドルに該当する文字列数を取得(注：Null文字は含まない)  
47.     length = SendMessageStr(hwnd, WM_GETTEXTLENGTH, 0, 0)  
48.     length = length + 1 'Null文字分１つ増やす  
49.       
50.     'Null文字分一つ多く領域を確保  
51.     str = String(length, vbNullChar)  
52.       
53.     'Null文字も含め受取る  
54.     Ret = SendMessageStr(hwnd, WM_GETTEXT, length, str)  
55.       
56.     '文字列を出力(NULL文字分１つ削って出力)  
57.     WindowTitle = Left(str, Len(str) - 1)  
58.       
59.     '取得したウィンドウ名がGetHwndの引数に指定された正規表現がマッチしたら取得しておく  
60.     If RegWindowTitle.Test(WindowTitle) Then  
61.         'クラス名が何文字か不明なので大きめの領域を確保しておく  
62.         ClassName = String(255, vbNullChar)  
63.         Ret = GetClassName(hwnd, ClassName, 255)  
64.         ClassName = Replace(ClassName, vbNullChar, "")  
65.           
66.         DicHwnd.Add CStr(hwnd), CreateObject("Scripting.Dictionary")  
67.         DicHwnd(CStr(hwnd)).Add "ClassName", ClassName  
68.         DicHwnd(CStr(hwnd)).Add "WindowName", WindowTitle  
69.     End If  
70.       
71. End Function  
72.   
73. Private Function EscapeRegString(ByVal RegHwnd As String)  
74.     RegHwnd = Replace(RegHwnd, "(", "\(")  
75.     RegHwnd = Replace(RegHwnd, ")", "\)")  
76.     RegHwnd = Replace(RegHwnd, ".", "\.")  
77.     RegHwnd = Replace(RegHwnd, "[", "\[")  
78.       
79.     EscapeRegString = RegHwnd  
80. End Function  

Option Explicit

Private Declare Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As Long, 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 SendMessageStr Lib "user32.dll" Alias "SendMessageA" _
       (ByVal hwnd As Long, ByVal MSG As Long, _
        ByVal wParam As Long, ByVal lParam As String) As Long

Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE

Private DicHwnd As Object
Private RegWindowTitle As Object

Public Function GetHwnd(ByVal RegPattern As String) As Object
    Dim Ret As Long
    
    'FileNameに一致するハンドルをキーにタイトルを値に格納する変数
    'CallBack関数とやりとりするのでGlobal領域で宣言しておく
    Set DicHwnd = CreateObject("Scripting.Dictionary")
    Set RegWindowTitle = CreateObject("VBScript.RegExp")
    
    RegWindowTitle.Global = False
    RegWindowTitle.IgnoreCase = True
    RegWindowTitle.Pattern = EscapeRegString(RegPattern)

    '必ずエラーになるので止まらないよう処理しておく
    On Error Resume Next
    Ret = EnumWindows(AddressOf EnumWindowsProc, 0)
    On Error GoTo 0 '問題の部分を過ぎたのでエラー処理をもとに戻す
    
    Set GetHwnd = DicHwnd
    Set DicHwnd = Nothing
End Function

Private Function EnumWindowsProc(ByVal hwnd As Long) As Long
    Dim ClassName   As String
    Dim length      As Integer
    Dim Ret         As Integer
    Dim str         As String
    Dim WindowTitle As String
    
    EnumWindowsProc = 1
    
    'ハンドルに該当する文字列数を取得(注：Null文字は含まない)
    length = SendMessageStr(hwnd, WM_GETTEXTLENGTH, 0, 0)
    length = length + 1 'Null文字分１つ増やす
    
    'Null文字分一つ多く領域を確保
    str = String(length, vbNullChar)
    
    'Null文字も含め受取る
    Ret = SendMessageStr(hwnd, WM_GETTEXT, length, str)
    
    '文字列を出力(NULL文字分１つ削って出力)
    WindowTitle = Left(str, Len(str) - 1)
    
    '取得したウィンドウ名がGetHwndの引数に指定された正規表現がマッチしたら取得しておく
    If RegWindowTitle.Test(WindowTitle) Then
        'クラス名が何文字か不明なので大きめの領域を確保しておく
        ClassName = String(255, vbNullChar)
        Ret = GetClassName(hwnd, ClassName, 255)
        ClassName = Replace(ClassName, vbNullChar, "")
        
        DicHwnd.Add CStr(hwnd), CreateObject("Scripting.Dictionary")
        DicHwnd(CStr(hwnd)).Add "ClassName", ClassName
        DicHwnd(CStr(hwnd)).Add "WindowName", WindowTitle
    End If
    
End Function

Private Function EscapeRegString(ByVal RegHwnd As String)
    RegHwnd = Replace(RegHwnd, "(", "\(")
    RegHwnd = Replace(RegHwnd, ")", "\)")
    RegHwnd = Replace(RegHwnd, ".", "\.")
    RegHwnd = Replace(RegHwnd, "[", "\[")
    
    EscapeRegString = RegHwnd
End Function

こんな感じで値が取れます。
メモ帳を2つ起動した状態で、メモ帳のハンドルを取得したいとします。

view plainprint?

1. Option Explicit  
2.   
3. Sub SampleCode()  
4.     Dim hwnd     As Variant  
5.     Dim HashHwnd As Object  
6.     Set HashHwnd = GetHwnd("メモ帳$")  
7.       
8.     For Each hwnd In HashHwnd  
9.         Debug.Print "ハンドル:" & hwnd  
10.         Debug.Print "クラス名:" & HashHwnd(hwnd)("ClassName")  
11.         Debug.Print "タイトル:" & HashHwnd(hwnd)("WindowName")  
12.         Debug.Print "---"  
13.     Next  
14. End Sub  

Option Explicit

Sub SampleCode()
    Dim hwnd     As Variant
    Dim HashHwnd As Object
    Set HashHwnd = GetHwnd("メモ帳$")
    
    For Each hwnd In HashHwnd
        Debug.Print "ハンドル:" & hwnd
        Debug.Print "クラス名:" & HashHwnd(hwnd)("ClassName")
        Debug.Print "タイトル:" & HashHwnd(hwnd)("WindowName")
        Debug.Print "---"
    Next
End Sub

実行結果

ハンドル:197350
クラス名:Notepad
タイトル:無題 - メモ帳
---
ハンドル:262876
クラス名:Notepad
タイトル:無題 - メモ帳
---

>Blog Top Page >[ExcelVBA] Top Page >[ExcelVBA] ExcelVBA ALL >[ExcelVBA] AdventCalendar