VBA – 備忘録

クリップボード内を監視し、キャプチャ画像をエクセルに貼り付ける。

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

スクリーンセーバーを起動しないよう、エクセルVBAから定期的にキーを送信する。

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)

Public Sub TimerSendKeys()
 '定期的にSCROLLLOCKキーを２回送信し、画面のスリープを抑止
 'A1セルに任意の文字列を入力されたらループ処理を終了する

Dim iTime As Integer    '秒数用カウンタ

Do
    'キーの送信は５分おき（３００秒おき）
    For iTime = 1 To 300
        '１秒スリープ
        Sleep 1000
        '画面更新
        DoEvents
        '終了リクエストを確認
        If Trim(ActiveSheet.Cells(1, 1).Value) <> "" Then Exit Do
    Next
    'SCROLLLOCKキーを２回送信（無害そうなキー、設定と解除で２回）
    Application.SendKeys ("{SCROLLLOCK 2}")
Loop

'終了リクエストをクリアして終了
ActiveSheet.Cells(1, 1).Value = ""

End Sub