クリップボード内を監視し、キャプチャ画像をエクセルに貼り付ける。
Option Explicit
Private Declare Function OpenClipboard Lib "user32" (Optional ByVal hwnd As Long = 0) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Public Sub AutoCapture()
'クリップボードを監視し、画像が取得されたらエクセルファイルに貼り付けてクリップボードをクリアする
'A1セルに任意の文字列を入力されたらループ処理を終了する
'B1セルに入力された数値＋２行の次行から画像を貼り付ける
Dim CB As Variant 'クリップボード
Dim SKey As String 'セル入力値取得用
Dim iLoop As Integer 'ループ用カウンタ
Dim OffsetY As Integer '画像貼り付け位置
Dim iHeight As Integer '画像の高さ（行数）
iHeight = 50 '取得画像の高さを50行に設定
'開始メッセージの表示
MsgBox "キャプチャの取り込みを開始します。" & vbCrLf & "終了するにはA1セルに文字入力して下さい。", vbInformation
'無限ループの開始
Do While True
'終了リクエストを確認
If Trim(ActiveSheet.Cells(1, 1).Value) <> "" Then GoTo QUIT_CAPTURE
'クリップボードの取得
CB = Application.ClipboardFormats
'値が格納されていれば取り込み処理を行う
If CB(1) <> -1 Then
For iLoop = 1 To UBound(CB)
'貼り付け対象はスクリーンショットのみ
If CB(iLoop) = xlClipboardFormatBitmap Then
'アクティブシートから貼り付け位置の取得
SKey = ActiveSheet.Cells(1, 2).Value
If IsNumeric(SKey) Then
OffsetY = Int(SKey)
Else
OffsetY = 0 '初期値
End If
'スクリーンショットをアクティブシートに貼り付け
ActiveSheet.Paste Destination:=Range("A3").Offset(OffsetY, 0)
'次の画像の貼り付け位置を計算
OffsetY = OffsetY + iHeight
'貼り付け位置をアクティブシートに書き戻す
ActiveSheet.Cells(1, 2).Value = OffsetY
'クリップボードをクリア
OpenClipboard
EmptyClipboard
CloseClipboard
End If
Next iLoop
End If
DoEvents
Loop
QUIT_CAPTURE:
'ループを抜ける処理
MsgBox "キャプチャの取り込みを停止しました。", vbInformation
ActiveSheet.Cells(1, 1).ClearContents
End Sub