VBAからGDI+を使う資料集
inet上の達人の方々から御教示いただいたコードを少しアレンジさせてもらっています(切り貼りとも言います)。
  1. ホーム
  2. Other
  3. controlOtherMacroBook


人様の作成したマクロブックのコマンドボタンを逐次キックして自動実行(Msgboxに自動応答して中断防止)

別Workbookのワークシートのコマンドボタンをキックして実行し、表示されたメッセージボックスに自動応答して、閉じます
自作なら、そんなメッセージボックスを表示するなよ、という事ですが、人様の作成したマクロブックを自動操作したい時に役に立ちます。

WindowsAPIのタイマーを使用する事で、モーダルなメッセージボックスのダイアログに情報を渡して操作する事ができます。

もともとはファイル名指定のダイアログにファイル名を与えようとトライしたのですが、
そちらはWindows7の例では相当階層が深くなっていて、思うようにEditのハンドルが取得できないことが多く、停滞しています


'ActiveXコントロールのCommandButtonをSheet1に二個設けたtargetMacroBook.xlsmの
'VBAプロジェクトには保護を掛けて、コードを見られない様にします。(人様作成のブック制御の模擬です)
'このブックのVBAコードを、後述のcontrolOtherMacroBook.xlsmから実行し、
'途中でMsgboxが表示されれば、自動応答して、中断しないようにして、
'連続実行させようという試みです。

'☆ Sheet1モジュール
Private Sub CommandButton1_Click()
  MsgBox "処理終了しました"
End Sub

Private Sub CommandButton2_Click()
 Dim rc As VbMsgBoxResult
 
  rc = MsgBox("続行しますか?", vbYesNo + vbQuestion)
  If rc = vbYes Then
    MsgBox "「はい」が選択されました"
  Else
    MsgBox "「いいえ」が選択されました"
  End If
End Sub

'controlOtherMacroBook.xlsmの標準モジュール
'☆ Module1

'事前にgetCommandButtonInfoを実行して、制御したい相手のブックの
'CommandButtonの情報を取得しておきます。TopLeftとかBottomRightセルの番地を取得するのも
'ボタンの特定に役立つでしょう。

'使い方
Sub test1()
  Dim sh As Worksheet
  Dim wbk As Workbook
  Dim hWnd As Long
        
  Set wbk = Application.Workbooks("targetMacroBook.xlsm")
  hWnd = Application.hWnd
  'ダイアログの自動操作設定
  
  'ダイアログが一回だけ表示されるとき
  timerMode = 1 'OKボタンOnly
  timerCnt = 0   '動作上限回数指定カウンタリセット 50回×0.1秒 = 5秒を最大にしてある
  Call SetTimer(hWnd, MY_TIMER_ID, MY_TIMER_MSEC, AddressOf TimerProc)
  wbk.Worksheets("Sheet1").OLEObjects("CommandButton1").Object.Value = True
  
  'ダイアログが複数回表示されるとき
  timerCnt = 0   '動作上限回数指定カウンタリセット 50回×0.1秒 = 5秒を最大にしてある
  Call SetTimer(hWnd, MY_TIMER_ID, MY_TIMER_MSEC, AddressOf TimerProc2)
  wbk.Worksheets("Sheet1").OLEObjects("CommandButton2").Object.Value = True
  Call KillTimer(hWnd, MY_TIMER_ID)
  
End Sub

'普通に実行する場合
'Msgboxに応答する必要があり、実行が途絶えてしまう。
Sub test0()
  Dim sh As Worksheet
  Dim wbk As Workbook
  Dim hWnd As Long
        
  Set wbk = Application.Workbooks("targetMacroBook.xlsm")
  
  wbk.Worksheets("Sheet1").OLEObjects("CommandButton1").Object.Value = True
  wbk.Worksheets("Sheet1").OLEObjects("CommandButton2").Object.Value = True
End Sub

'コマンドボタン情報取得
'人様の作成したマクロブック(VBAコード保護)で、自動操作に用いるため
'コマンドボタンの情報を取得するコード

Sub getCommandButtonInfo()
  Dim wbk As Workbook
  Dim sh As Worksheet
  Dim shp As Shape
  Dim myOleObj As OLEObject
'  Dim myDrawObj As DrawingObject 'こんな型は無かった
' shpに該当するコマンドボタンが入った状態でstopし、Local WindowのDrawingObjectからメンバを確認した
    
  Const toolName As String = "targetMacroBook.xlsm"
  
  Set wbk = Workbooks(toolName)
  For Each sh In wbk.Worksheets
    For Each shp In sh.Shapes
      Select Case shp.Type
        Case 12 'msoOLEControlObject
          'Control_CommandButton
          Set myOleObj = sh.OLEObjects(shp.Name)
          If myOleObj.progID = "Forms.CommandButton.1" Then
            Debug.Print sh.Name, myOleObj.Name, myOleObj.Object.Caption
          '*** 取得した名前からプロシージャの実行 ***
            'sh.OLEObjects("CommandButton1").Object.Value = True '名前から、左記の様に実行可能
          End If
        Case 8 'msoFormControl
          'Form_CommandButton
          Debug.Print sh.Name, shp.Name, shp.DrawingObject.Caption, shp.DrawingObject.OnAction
          '*** 取得した名前からプロシージャの実行 ***
          'shp.DrawingObject.Value = 1 '無効、メンバ無し
          'Application.Run sh.Shapes("Button 3").DrawingObject.OnAction 'これで実行可能
      End Select
    Next shp
  Next sh
End Sub

'☆ ctrlDialogモジュール
'Windows API宣言'
Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, _
                                        ByVal nIDEvent As Long, _
                                        ByVal uElapse As Long, _
                                        ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, _
                                        ByVal nIDEvent As Long) As Long
Public Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Public Declare Function FindWindowEx Lib "user32.dll" _
    Alias "FindWindowExA" ( _
    ByVal hWndParent As Long, _
    ByVal hwndChildAfter As Long, _
    ByVal lpszClass As String, _
    ByVal lpszWindow As String) As Long
    
'第1引数は、Findwindowで取得したハンドル
'第2引数は、同じクラス名のオブジェクトがあった場合に、最初に見つかった
'子ハンドルを渡すと次の同じ名前の子ハンドルを取得。
'第3引数は、知りたいオブジェクトのクラス名を指定。Spy等で調査しておく。
'第4引数は、ウィンドウ名(vbのフォームに配置するオブジェクトのプロパティの時、キャプション)

Public Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" _
        (ByVal hWnd As Long, ByVal msg As Long, _
        ByVal wParam As Long, ByVal lParam As Any) As Long

'定数定義'
Public Const MY_TIMER_ID      As Long = 100001   'タイマーID(任意値)'
Public Const MY_TIMER_MSEC     As Long = 100       '0.1秒間隔'

'TimerProcの動作指定変数
Public timerMode As Long

'Timerの動作回数->動作時間上限設定
Const maxCnt As Long = 50
Public timerCnt As Long

'ダイアログ監視タイマーセット

'タイマー用のSubには必ずOn Error Resume Nextを行うこと。でないとエラーが発生したときにEXCELごと終了してしまう。
'と、どこかで読んだが、入れてみても、結局単純なSyntax Errorで容易に暴走してしまうので要注意。

'使い方 TimerProc
' ダイアログが1回しか表示されない場合。一回実行するとタイマー解除。
'    timerMode = 1  動作モード指定
'     timerMode=1: OKボタン
'     timerMode=2: Yes/Noボタン
'     以下、必要に応じて作り込む。
'    timerCnt = 0   動作上限回数指定カウンタリセット
'    Call SetTimer(hWnd, MY_TIMER_ID, MY_TIMER_MSEC, AddressOf TimerProc)

'使い方 TimerProc2
' ダイアログが複数表示されるとき。タイマー解除は処理終了後に行う様組み込み要
'    timerCnt = 0   動作上限回数指定カウンタリセット
'    Call SetTimer(hWnd, MY_TIMER_ID, MY_TIMER_MSEC, AddressOf TimerProc2)
'    Call KillTimer(hWnd, MY_TIMER_ID)

'Msgbox表示が一回だけの場合
'内部でタイマーを解除している
Public Function TimerProc(ByVal hWnd As Long, ByVal msg As Long, _
                           ByVal wp As Long, ByVal lp As Long) As Long
                           
  Dim dlHWnd As Long
  Dim chWnd As Long
                         
  On Error Resume Next
  timerCnt = timerCnt + 1
  '50回実施した場合、タイマーを解除する。
  If timerCnt > 50 Then Call KillTimer(hWnd, MY_TIMER_ID)
  
  Select Case wp
    Case MY_TIMER_ID
'        'タイマー処理'
      Select Case timerMode
        Case 1
          'Spyでみると、#32770 (ダイアログ)になっている
          dlHWnd = FindWindow("#32770", "Microsoft Excel")
          If dlHWnd = 0 Then Exit Function
          'タイマー再設定停止
          Call KillTimer(hWnd, MY_TIMER_ID)
          chWnd = FindWindowEx(dlHWnd, 0&, "BUTTON", "OK")
          If chWnd > 0 Then
            Call SendMessage(chWnd, &H6, 1, 0&)  'ボタンをアクティブにする
            Call SendMessage(chWnd, &HF5, 0, 0&) 'ボタンをクリックする
          End If
        Case 2
          dlHWnd = FindWindow("#32770", "Microsoft Excel")
          If dlHWnd = 0 Then Exit Function
          'タイマー再設定停止
          Call KillTimer(hWnd, MY_TIMER_ID)
          chWnd = FindWindowEx(dlHWnd, 0&, "BUTTON", "はい(&Y)")  '&が必要
          If chWnd > 0 Then
            Call SendMessage(chWnd, &H6, 1, 0&)  'ボタンをアクティブにする
            Call SendMessage(chWnd, &HF5, 0, 0&) 'ボタンをクリックする
          End If
        Case Else
          Call KillTimer(hWnd, MY_TIMER_ID)
      End Select
  End Select

End Function

'Msgbox表示が複数回の場合
'呼び元のプロシージャでタイマーを解除する必要有り
Public Function TimerProc2(ByVal hWnd As Long, ByVal msg As Long, _
                           ByVal wp As Long, ByVal lp As Long) As Long
                           
  Dim dlHWnd As Long
  Dim chWnd As Long
                         
  On Error Resume Next
  timerCnt = timerCnt + 1
  '5秒以上経過したら、タイマー再設定を止める
  If timerCnt > 50 Then Call KillTimer(hWnd, MY_TIMER_ID)
  Select Case wp
    Case MY_TIMER_ID
        'タイマー処理'
        'Spyでみると、#32770 (ダイアログ)になっている
        dlHWnd = FindWindow("#32770", "Microsoft Excel")
  '      Debug.Print "hWnd:", dlHWnd
        If dlHWnd = 0 Then Exit Function
        'OKボタンがあればクリック
        chWnd = FindWindowEx(dlHWnd, 0&, "BUTTON", "OK")
        If chWnd > 0 Then
          Call SendMessage(chWnd, &H6, 1, 0&)  'ボタンをアクティブにする
          Call SendMessage(chWnd, &HF5, 0, 0&) 'ボタンをクリックする
        Else
          'OKボタンがないとき、はい(Y)ボタンがあればクリック
          chWnd = FindWindowEx(dlHWnd, 0&, "BUTTON", "はい(&Y)")  '&が必要
          
          If chWnd > 0 Then
            Call SendMessage(chWnd, &H6, 1, 0&)  'ボタンをアクティブにする
            Call SendMessage(chWnd, &HF5, 0, 0&) 'ボタンをクリックする
          End If
        End If
  End Select
  
End Function