エビデンス！エビデンス！！エビデンス！！！ VBAでクリップボード監視 その2

前回 → エビデンス！エビデンス！！エビデンス！！！　VBAでクリップボード監視
ユーザーフォームのソースコード → gist
標準モジュールのソースコード → gist

まずはユーザーフォームモジュールのコードから。

Private Sub CheckBox1_Change()
    If CheckBox1.Value = True Then
        Module1.catchClipboard
    Else
        Module1.releaseClipboard
    End If
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CheckBox1.Value = True Then
        Module1.releaseClipboard
        CheckBox1.Value = False
    End If
End Sub

チェックボックスをチェックしたら、クリップボード監視（標準モジュールのcatchClipboardを実行）、 チェックを外したら、クリップボード監視終了（標準モジュールのreleaseClipboardを実行）。
チェックボックス外し忘れでフォームを閉じたときのための、念のためQueryCloseの時にもreleaseClipboardを実行。 以上。

では次に、標準モジュールのコード。

Option Explicit

Private Declare PtrSafe Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function SetClipboardViewer Lib "user32.dll" (ByVal hWndNewViewer As LongPtr) As LongPtr
Private Declare PtrSafe Function ChangeClipboardChain Lib "user32.dll" (ByVal hWndRemove As LongPtr, ByVal hWndNewNext As LongPtr) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal format As Long) As Long

Private Const GWL_WNDPROC As Long = -4

Private Const WM_DRAWCLIPBOARD As Long = &H308
Private Const WM_CHANGECBCHAIN As Long = &H30D
Private Const WM_NCHITTEST As Long = &H84

Private Const CF_BITMAP As Long = 2

Private Const ROW_HEIGHT As Double = 13.5

Private hWndForm As LongPtr
Private wpWindowProcOrg As Long
Private hWndNextViewer As LongPtr
Private firstFired As Boolean

Public Sub catchClipboard()
    hWndForm = FindWindow("ThunderDFrame", UserForm1.Caption)
    wpWindowProcOrg = SetWindowLong(hWndForm, GWL_WNDPROC, AddressOf WindowProc)
    firstFired = False
    hWndNextViewer = SetClipboardViewer(hWndForm)
End Sub

Public Sub releaseClipboard()
    Call ChangeClipboardChain(hWndForm, hWndNextViewer)
    Call SetWindowLong(hWndForm, GWL_WNDPROC, wpWindowProcOrg)
End Sub

Public Function WindowProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Select Case uMsg
        Case WM_DRAWCLIPBOARD
            If Not firstFired Then
                firstFired = True
            ElseIf IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
                pasteToSheet
            End If
            If hWndNextViewer <> 0 Then
                Call SendMessage(hWndNextViewer, uMsg, wParam, lParam)
            End If
            WindowProc = 0
        Case WM_CHANGECBCHAIN
            If wParam = hWndNextViewer Then
                hWndNextViewer = lParam
            ElseIf hWndNextViewer <> 0 Then
                Call SendMessage(hWndNextViewer, uMsg, wParam, lParam)
            End If
            WindowProc = 0
        Case WM_NCHITTEST
            WindowProc = 0
        Case Else
            WindowProc = CallWindowProc(wpWindowProcOrg, hWndForm, uMsg, wParam, lParam)
    End Select
End Function

Public Sub pasteToSheet()
    Dim rowIdx As Integer
    
    With Sheet1
        If .Shapes.Count > 0 Then
            With .Shapes(.Shapes.Count)
                rowIdx = (.Top + .Height) / ROW_HEIGHT + 4
            End With
        Else
            rowIdx = 1
        End If
        .Cells(rowIdx, 1).PasteSpecial
    End With
End Sub

フォームから呼ばれる監視スタートのcatchClipboardは…

1. FindWindowでフォームのハンドルを取得します。
   フォームのクラスは"ThunderDFrame"というらしいです。第2引数でフォームのキャプションを指定します。UserForm.Handleとかしたいのですが、少なくとも2010のVBAでは無理っぽいです。回りくどい。
   
2. SetWindowLongでウィンドウプロシージャを自分で定義したWindowProcに入れ替える。
   この時の戻り値は、入れ替える前のウィンドウプロシージャのアドレスなので、記憶しておきます。
   
3. firstFiredフラグをFalseにしておきます。
   この次の行でクリップボード監視を始めるのですが、SetClipboardViewerをした瞬間に、なぜか いきなり「クリップボードの中身が入れ替わった」イベント(後述するWindowProcにWM_DRAWCLIPBOARDが渡される)が発火してしま います。なので、それを抑えるために。
   
4. SetClipboardViewerで、フォームをクリップボードビューアのチェーンにつなぎます。
   クリップボードのイベントを受け取るクリップボードビューアは、鎖のように連なっています。詳しくは後述。
   ここでの返り値は、自分の一つ後ろのクリップボードビューア（なければ0が返ります）なので、それを記憶しておきます。

一方、フォームから呼ばれる監視ストップのreleaseClipboardは…

1. ChangeClipboardChainでフォームをクリップボードビューアのチェーンから切り離します。
   第1引数は切り離すウィンドウのハンドル、第2引数は切り離すウィンドウの一つ後ろのクリップボードビューアのハンドルです。
   
2. SetWindowLongでフォームのウィンドウプロシージャを元に戻します。
   ちなみに、SetWindowLongを使っていますが、VBAでなくVBならば、SetWindowLongPtr(SetWindowLongPrtA)という関数が使えます。
   これは、第3引数と返り値がLongPtrになり、多い日も安心な感じがします。
   64bitを徹底的に気にするなら、本来はこちらを使うべきなのですが、user32.dllではなく、user32.libの関数のようで、だめでした。
   前回書いた通り、別にすべてのLongPtrをLongにしても大丈夫だと思います。きっと。

さて、catchClipboardにて、フォームのウィンドウプロシージャを"WindowProc"に入れ替えました。こういうのを、「サブクラス化」というらしいのですが、ではWindowProcを見てみます。
まず受け取ったメッセージuMsgを見てみます。

1. WM_DRAWCLIPBOARDであれば…
   クリップボードの中身が変わったイベントです。このイベントはSetClipboardViewerを使った瞬間にもなぜか起きるので、そこはfirstFiredで調節しています。
   次 に、IsClipboardFormatAvailableで、中身がビットマップかどうかを判定しています。(Alt+)PrintScreenを使う と、ビットマップになります。テキストとかをコピペした時は無視させるためです。でビットマップならば、pasteToSheetでシートに貼りつけま す。
   最後に、次のクリップボードビューアが0でない（存在する）ならば、SendMessageでフォームが受け取ったメッセージを渡してやります。
   これは「クリップボードビューアは鎖のように連なっている」ためです。これをしないと、後続のクリップボードビューアが処理できません。見方を変えれば、後続に処理させたくない場合には、SendMessageを使わなければよいわけです。
   ここでは、シートに絵を貼りつけた後は別にクリップボードを独占する必要はないので、後続のビューアにメッセージを送ってやっています。
   
2. WM_CHANGECBCHAINであれば…
   クリップボードビューアチェーンの誰かが離脱したイベントです。
   この時、OSで勝手にチェーンをつなぎかえてはくれません。自分でやります。
   wParamが離脱するビューア、lParamがその次のビューアのハンドルです。つまり、ChangeClipboardChainの引数そのものだったりします。
   なので、wParamが自分の一つ後ろならば、hWndNextViewerをlParamにしてやります。また、そうでないならば、自分は何もせずにSendMessageで後ろのビューアにメッセージを渡してやります。
   
3.  WM_NCHITTESTであれば…
   これは実ははまるところなのですが、クリップボードの処理に直接関係ないので、次回に飛ばします。
   
4.  それ以外であれば…
   フォームにやってくるメッセージは、クリップボード関連だけではありません。なんせ普通のフォームなので、マウスやキーなどのイベントのメッセージがやってきます（上のWM_NCHITTESTはマウス関連のイベントです）。
   そうした場合には、フォーム本来の処理をさせるべきです。
   そこで、CallWindowProcで、もともとフォームが持っていたウィンドウプロシージャを呼び出してやります。

最後に、pasteToSheetですが、これはまあコードを見ればOKかと思います。 Sheet1に次々とクリップボードの中身を貼りつけてやっています。