毎度変わる子ウィンドウハンドルを用いて入出力

今回は部内で32bitのExcelを利用しているため、
32bitのExcelを前提として記述。

操りたいウィンドウのイメージを掲載する。
「在庫確認」という文字列をタイトルに含んだウィンドウを親と認識。
親に紐づくテキストボックスは子ウィンドウとして羅列しようという計画。

まずはいろいろ道具を宣言しておきます。

Option Explicit
'-------------------------------------
' 各種方法でウィンドウを取得
'-------------------------------------
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function GetWindow Lib "user32" _
(ByVal hwnd As Long, ByVal wCmd As Long) As Long

'-------------------------------------
'　親ハンドルの取得
'-------------------------------------
Private Declare Function GetParent Lib "user32" (ByVal hwnd 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 GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, _
ByVal cch As Long) As Long

'-------------------------------------
' 指定された親ウィンドウに属する子ウィンドウを列挙する関数の宣言
'-------------------------------------
Private Declare Function EnumChildWindows Lib "user32" _
(ByVal hWndParent As Long, ByVal lpEnumFunc As Long, _
ByRef lParam() As Long) As Long

'-------------------------------------
' 指定時間待機の部品
'-------------------------------------
Private Declare Sub sleep Lib "kernel32" Alias "Sleep" (ByVal ms As Long)

'-------------------------------------
' ウィンドウハンドルを指定して文字列を送信・取得など
'-------------------------------------
Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal msg As Long, _
ByVal wParam As Long, _
ByVal lParam As String) As Long

Declare Function SendMessageStr Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal msg As Long, _
ByVal wParam As Long, _
ByVal lParam As String) As Long

'------------------------------------------------------------------------------
' 指定の文字列が含まれたウィンドウのハンドルを取得
'------------------------------------------------------------------------------
Public Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long

'------------------------------------------------------------------------------
' 指定の文字列が含まれたウィンドウのハンドルを取得
'------------------------------------------------------------------------------
Function GetHwnd(ByVal cap_str As String) As Long

    Dim hwnd        As LongPtr
    Dim wCaption    As String * 255

    '基準となるウィンドウハンドルを取得
    'FindWindow は、どちらの引数にも vbNullString を指定すると
    '最前面のウィンドウのハンドルを返す
    hwnd = FindWindow(vbNullString, vbNullString)

    Do Until hwnd = 0

        '可視ウィンドウのみ
        If CBool(IsWindowVisible(hwnd)) Then
            'ウィンドウのキャプション（タイトル文字列）を取得
            'GetWindowText は、ウィンドウタイトルをバッファ（wCaption）に格納する
            GetWindowText hwnd, wCaption, Len(wCaption)
            If InStr(wCaption, cap_str) > 0 Then Exit Do
        End If

        '次のウィンドウのウィンドウハンドルを取得
        'GetWindow は、第二引数に GW_HWNDNEXT（=2）をして指定すると
        '次のウィンドウのハンドルを返す
        hwnd = GetWindow(hwnd, 2)
    Loop

    GetHwnd = hwnd

End Function

ウィンドウハンドルを列挙したエクセルシートのうち、
該当の子ウィンドウハンドルが格納されるセルは同じだった。
→セルで指定してハンドルを取得！

'------------------------------------------------------------------------------
' Main
'------------------------------------------------------------------------------
Sub Main()
    Dim lParam() As Long 'ウィンドウハンドル格納域
    Dim i As Long

    ReDim lParam(0) 'とりあえず領域確保
    
    Dim wsE As Worksheet
    Set wsE = ThisWorkbook.Worksheets("EnumList")
    
    wsE.Range("A:k").ClearContents ' リストクリア
    
    wsE.Cells(1, 1).Value = "親ハンドル"
    wsE.Cells(1, 2).Value = "自ハンドル"
    wsE.Cells(1, 3).Value = "クラス名"
    wsE.Cells(1, 4).Value = "ウィンドウタイトル" 'ヘッダ入力
    
    'ZAIKAKUのウィンドウを取得 = 在庫確認という文字が入っているものを取得
    Dim hwnd As Long
    hwnd = GetHwnd("在庫確認")
    Debug.Print hwnd
    
    'ウィンドウが無ければ起動
    Dim sh As Long
    If hwnd = 0 Then
        sh = Shell("C:\nit_fil\999\ZAIKAKU.EXE", vbNormalFocus) '起動
        For i = 1 To 10
            sleep 7000 '念のため待機、極めつけにウィンドウが無ければ繰り返し待機
            hwnd = GetHwnd("在庫確認")
            If hwnd > 0 Then
                Exit For
            Else
            End If
        Next i
    Else
    End If
    
    'Zaikakuウィンドウの全ての子ウィンドウをシートに記載
    Call EnumChildWindows(hwnd, AddressOf EnumChildProc, lParam)

    For i = 1 To UBound(lParam) '配列の0番目は使っていません
    Call SetList(i + 1, lParam(i)) 'タイトル分+1してシートに列挙
    Next
    
    '念の為シートに説明追加
    wsE.Range("D39").Value = "店コード"
    wsE.Range("D46").Value = "商品コード1"
    wsE.Range("D45").Value = "商品名1"
    wsE.Range("D44").Value = "確認数量1"
    wsE.Range("D42").Value = "引当て結果1"
    wsE.Range("D29").Value = "商品コード2"
    wsE.Range("D30").Value = "商品名2"
    wsE.Range("D31").Value = "確認数量2"
    wsE.Range("D33").Value = "引当て結果2"
    wsE.Range("D22").Value = "商品コード3"
    wsE.Range("D23").Value = "商品名3"
    wsE.Range("D24").Value = "確認数量3"
    wsE.Range("D26").Value = "引当て結果3"
    wsE.Range("D15").Value = "商品コード4"
    wsE.Range("D16").Value = "商品名4"
    wsE.Range("D17").Value = "確認数量4"
    wsE.Range("D19").Value = "引当て結果4"
    wsE.Range("D8").Value = "商品コード5"
    wsE.Range("D9").Value = "商品名5"
    wsE.Range("D10").Value = "確認数量5"
    wsE.Range("D12").Value = "引当て結果5"
    
    '最終行が増えていたら、UPDATEの可能性を示唆
    Dim maxRow As Long
    maxRow = wsE.Cells(Rows.Count, 1).End(xlUp).Row
    If maxRow > 46 Then
        MsgBox "もしかしたら在確画面の要素が更新されているかも！非表示シートを参照してコードを修正してみてね！"
    Else
    End If
    
    '入力・出力開始
    makeList
    
    Application.StatusBar = "完了! 通販バンザイ！"
    
End Sub


'-------------------------------------
' コールバック関数 - 子ウィンドウを列挙
'-------------------------------------
Private Function EnumChildProc(ByVal hwnd As Long, ByRef lParam() As Long) As Long

    '参照形式で受け取ったポインター配列に見つかったハンドルを追加
    ReDim Preserve lParam(UBound(lParam) + 1) '領域拡張
    lParam(UBound(lParam)) = hwnd 'ウィンドウハンドルセット
    
    'コールバック関数の戻り値は、何等かの検索条件に一致し
    '検索を終了する場合にFalseを返して処理を終了するためにある
    EnumChildProc = True '列挙を継続
    
End Function

'-------------------------------------
' ウィンドウハンドルから各種情報を取得し、エクセルシートに書き出し
'-------------------------------------
Private Sub SetList(lngRow As Long, hwnd As Long)

    Dim Buffer As String * 512 'バッファ
    Dim wsE As Worksheet
    Set wsE = ThisWorkbook.Worksheets("EnumList")
    '親ハンドル取得が時々バグるのはなんなんだろう
    'トップレベルウインドウに実行したときに０でなく値が戻るときがある
    '実はこの動作のおかげでIEFrameとモダールの関係が分かったのではあるが（笑）
    wsE.Cells(lngRow, 1).Value = GetParent(hwnd) '親ハンドル
    wsE.Cells(lngRow, 2).Value = hwnd '自ハンドル

    'クラス名
    Dim strClassName As String
    Call GetClassName(hwnd, Buffer, Len(Buffer))
    strClassName = Left(Buffer, InStr(Buffer, vbNullChar) - 1)
    wsE.Cells(lngRow, 3).Value = strClassName ' クラス名

    ' ウィンドウタイトル
    Call GetWindowText(hwnd, Buffer, Len(Buffer))
    wsE.Cells(lngRow, 4).Value = Left(Buffer, InStr(Buffer, vbNullChar) - 1) ' ウィンドウタイトル

End Sub

'-------------------------------------
' 子ウィンドウに情報を入力・出力・ボタンクリックの繰り返し
'-------------------------------------
Private Sub makeList()

    Dim wsE As Worksheet
    Set wsE = ThisWorkbook.Worksheets("EnumList")
    Dim wsL As Worksheet
    Set wsL = ThisWorkbook.Worksheets("商品CD貼付")
    Dim shopCd As String
    
    '店コードをセット
    If wsL.Range("B1").Value = "" Then
        MsgBox "店コードを入れてください"
        End
    Else
        shopCd = wsL.Range("B1").Value
    End If
    
    '入力数量をセット
    Dim amount As String
    If wsL.Range("D1").Value = "" Then
        amount = "1"
    Else
        amount = wsL.Range("D1").Value
    End If
    
    '配列にハンドル格納
    Dim hShop As Long
    Dim hCd(5) As Long
    Dim hProduct(5) As Long
    Dim hAmount(5) As Long
    Dim hZaikaku(5) As Long
    Dim hEnter As Long
    
    hShop = wsE.Range("B39").Value
    Debug.Print hShop
    hCd(1) = wsE.Range("B46").Value
    hCd(2) = wsE.Range("B29").Value
    hCd(3) = wsE.Range("B22").Value
    hCd(4) = wsE.Range("B15").Value
    hCd(5) = wsE.Range("B8").Value
    hProduct(1) = wsE.Range("B45").Value
    hProduct(2) = wsE.Range("B30").Value
    hProduct(3) = wsE.Range("B23").Value
    hProduct(4) = wsE.Range("B16").Value
    hProduct(5) = wsE.Range("B9").Value
    hAmount(1) = wsE.Range("B44").Value
    hAmount(2) = wsE.Range("B31").Value
    hAmount(3) = wsE.Range("B24").Value
    hAmount(4) = wsE.Range("B17").Value
    hAmount(5) = wsE.Range("B10").Value
    hZaikaku(1) = wsE.Range("B42").Value
    hZaikaku(2) = wsE.Range("B33").Value
    hZaikaku(3) = wsE.Range("B26").Value
    hZaikaku(4) = wsE.Range("B19").Value
    hZaikaku(5) = wsE.Range("B12").Value
    hEnter = wsE.Range("B6").Value
    
    Dim hwnd As Long
    hwnd = FindWindow("ThunderRT6FormDC", vbNullString)
    Debug.Print hwnd
    
    Dim send As Long
    send = SendMessage(hShop, &HC, 0, wsL.Range("B1").Text)
    
    
    '最終行取得からアイテム数取得
    Dim maxRow As Long
    maxRow = wsL.Cells(Rows.Count, 1).End(xlUp).Row
    
    Dim productAmount As Long
    productAmount = maxRow - 2
    Application.StatusBar = productAmount & "件開始"
    

    Dim quotient As Long '5で割った商
    quotient = Int(productAmount / 5)
    Debug.Print quotient
    
    Dim remainder As Long '5で割った余り
    remainder = productAmount Mod 5
    Debug.Print remainder

    Dim i As Long '5つ1セットで何セットあるか
    Dim j As Long '1から5をのぼる
    Dim k As Long '読み込み判定用インデックス
    Dim r As Long '記入行
    r = 3 '3行目から記入開始
    Dim lenStr As Long
    Dim str As String
    Dim productName As String
    Dim zaikaku As String
        
    If productAmount > 5 Then '5アイテム以上あったらこっち
        For i = 1 To quotient
        
            Select Case Int(r / productAmount * 100)
                Case 0 To 9
                    Application.StatusBar = productAmount & "件中" & (r - 2) & "件処理中　□□□□□□□□□□"
                Case 10 To 19
                    Application.StatusBar = productAmount & "件中" & (r - 2) & "件処理中　■□□□□□□□□□"
                Case 20 To 29
                    Application.StatusBar = productAmount & "件中" & (r - 2) & "件処理中　■■□□□□□□□□"
                Case 30 To 39
                    Application.StatusBar = productAmount & "件中" & (r - 2) & "件処理中　■■■□□□□□□□"
                Case 40 To 49
                    Application.StatusBar = productAmount & "件中" & (r - 2) & "件処理中　■■■■□□□□□□"
                Case 50 To 59
                    Application.StatusBar = productAmount & "件中" & (r - 2) & "件処理中　■■■■■□□□□□"
                Case 60 To 69
                    Application.StatusBar = productAmount & "件中" & (r - 2) & "件処理中　■■■■■■□□□□"
                Case 70 To 79
                    Application.StatusBar = productAmount & "件中" & (r - 2) & "件処理中　■■■■■■■□□□"
                Case 80 To 89
                    Application.StatusBar = productAmount & "件中" & (r - 2) & "件処理中　■■■■■■■■□□"
                Case 90 To 100
                    Application.StatusBar = productAmount & "件中" & (r - 2) & "件処理中　■■■■■■■■■□"
                Case Else
            End Select
            
            For j = 1 To 5
                send = SendMessage(hCd(j), &HC, 0, wsL.Cells(r, 1).Text)
                send = SendMessage(hAmount(j), &HC, 0, amount)
                
                r = r + 1
            Next j
            send = SendMessage(hEnter, &HF5, 0, 0) '確認Enter
            
            For k = 1 To 10 '在確読み込みまで待機繰り返し
                send = SendMessage(hZaikaku(1), &HE, 0, 0)
                If send > 0 Then
                    Exit For
                Else
                    sleep 1000
                End If
            Next k
            r = r - 5 '読み取り用にr値を戻す
            
            For j = 1 To 5 'ここから文字列取得
                lenStr = SendMessage(hProduct(j), &HE, 0, 0)
                str = String(lenStr, vbNullChar)
                send = SendMessage(hProduct(j), &HD, lenStr + 1, str)
                wsL.Cells(r, 2) = str
                
                lenStr = SendMessage(hZaikaku(j), &HE, 0, 0)
                str = String(lenStr, vbNullChar)
                send = SendMessage(hZaikaku(j), &HD, lenStr + 1, str)
                wsL.Cells(r, 3) = str
                
                r = r + 1
            Next j
        Next i
    Else
    remainder = productAmount
    End If
    
    '5で割り切れない余りのアイテム
    If remainder > 0 Then
        For j = 1 To remainder
            send = SendMessage(hCd(j), &HC, 0, wsL.Cells(r, 1).Text)
            send = SendMessage(hAmount(j), &HC, 0, amount)
            r = r + 1
        Next j
         send = SendMessage(hEnter, &HF5, 0, 0) '確認Enter
        
        For k = 1 To 10 '在確読み込みまで待機繰り返し
            send = SendMessage(hZaikaku(1), &HE, 0, 0)
            If send > 0 Then
                Exit For
            Else
                sleep 1000
            End If
        Next k
        r = r - remainder '読み取り用にr値を戻す
        
        For j = 1 To remainder 'ここから文字列取得
            lenStr = SendMessage(hProduct(j), &HE, 0, 0)
            str = String(lenStr, vbNullChar)
            send = SendMessage(hProduct(j), &HD, lenStr + 1, str)
            wsL.Cells(r, 2) = str
            
            lenStr = SendMessage(hZaikaku(j), &HE, 0, 0)
            str = String(lenStr, vbNullChar)
            send = SendMessage(hZaikaku(j), &HD, lenStr + 1, str)
            wsL.Cells(r, 3) = str
            
            r = r + 1
        Next j
        
    Else
    End If
End Sub

これで完成～