前回 →
エビデンス！エビデンス！！エビデンス！！！ 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は…
- FindWindowでフォームのハンドルを取得します。
フォームのクラスは"ThunderDFrame"というらしいです。第2引数でフォームのキャプションを指定します。UserForm.Handleとかしたいのですが、少なくとも2010のVBAでは無理っぽいです。回りくどい。
- SetWindowLongでウィンドウプロシージャを自分で定義したWindowProcに入れ替える。
この時の戻り値は、入れ替える前のウィンドウプロシージャのアドレスなので、記憶しておきます。
- firstFiredフラグをFalseにしておきます。
この次の行でクリップボード監視を始めるのですが、SetClipboardViewerをした瞬間に、なぜか
いきなり「クリップボードの中身が入れ替わった」イベント(後述するWindowProcにWM_DRAWCLIPBOARDが渡される)が発火してしま
います。なので、それを抑えるために。
- SetClipboardViewerで、フォームをクリップボードビューアのチェーンにつなぎます。
クリップボードのイベントを受け取るクリップボードビューアは、鎖のように連なっています。詳しくは後述。
ここでの返り値は、自分の一つ後ろのクリップボードビューア（なければ0が返ります）なので、それを記憶しておきます。
一方、フォームから呼ばれる監視ストップのreleaseClipboardは…
- ChangeClipboardChainでフォームをクリップボードビューアのチェーンから切り離します。
第1引数は切り離すウィンドウのハンドル、第2引数は切り離すウィンドウの一つ後ろのクリップボードビューアのハンドルです。
- SetWindowLongでフォームのウィンドウプロシージャを元に戻します。
ちなみに、SetWindowLongを使っていますが、VBAでなくVBならば、SetWindowLongPtr(SetWindowLongPrtA)という関数が使えます。
これは、第3引数と返り値がLongPtrになり、多い日も安心な感じがします。
64bitを徹底的に気にするなら、本来はこちらを使うべきなのですが、user32.dllではなく、user32.libの関数のようで、だめでした。
前回書いた通り、別にすべてのLongPtrをLongにしても大丈夫だと思います。きっと。
さて、catchClipboardにて、フォームのウィンドウプロシージャを"WindowProc"に入れ替えました。こういうのを、「サブクラス化」というらしいのですが、ではWindowProcを見てみます。
まず受け取ったメッセージuMsgを見てみます。
- WM_DRAWCLIPBOARDであれば…
クリップボードの中身が変わったイベントです。このイベントはSetClipboardViewerを使った瞬間にもなぜか起きるので、そこはfirstFiredで調節しています。
次
に、IsClipboardFormatAvailableで、中身がビットマップかどうかを判定しています。(Alt+)PrintScreenを使う
と、ビットマップになります。テキストとかをコピペした時は無視させるためです。でビットマップならば、pasteToSheetでシートに貼りつけま
す。
最後に、次のクリップボードビューアが0でない（存在する）ならば、SendMessageでフォームが受け取ったメッセージを渡してやります。
これは「クリップボードビューアは鎖のように連なっている」ためです。これをしないと、後続のクリップボードビューアが処理できません。見方を変えれば、後続に処理させたくない場合には、SendMessageを使わなければよいわけです。
ここでは、シートに絵を貼りつけた後は別にクリップボードを独占する必要はないので、後続のビューアにメッセージを送ってやっています。
- WM_CHANGECBCHAINであれば…
クリップボードビューアチェーンの誰かが離脱したイベントです。
この時、OSで勝手にチェーンをつなぎかえてはくれません。自分でやります。
wParamが離脱するビューア、lParamがその次のビューアのハンドルです。つまり、ChangeClipboardChainの引数そのものだったりします。
なので、wParamが自分の一つ後ろならば、hWndNextViewerをlParamにしてやります。また、そうでないならば、自分は何もせずにSendMessageで後ろのビューアにメッセージを渡してやります。
- WM_NCHITTESTであれば…
これは実ははまるところなのですが、クリップボードの処理に直接関係ないので、次回に飛ばします。
- それ以外であれば…
フォームにやってくるメッセージは、クリップボード関連だけではありません。なんせ普通のフォームなので、マウスやキーなどのイベントのメッセージがやってきます（上のWM_NCHITTESTはマウス関連のイベントです）。
そうした場合には、フォーム本来の処理をさせるべきです。
そこで、CallWindowProcで、もともとフォームが持っていたウィンドウプロシージャを呼び出してやります。
最後に、pasteToSheetですが、これはまあコードを見ればOKかと思います。
Sheet1に次々とクリップボードの中身を貼りつけてやっています。
