Excelを快適に使おう

'---------------------------------------------------------------------------------------------------
'
' マクロ: Excel以外のスクリーンショットを貼り続けます
'
' 動作のオンオフ：
'     他のウインドウを選択すると自動保存を開始します
'     再度エクセルをアクティブにすると終了します
'---------------------------------------------------------------------------------------------------
Option Explicit

#If Win64 Then
Declare PtrSafe Function OpenClipboard Lib "user32" (Optional ByVal hwnd As Long = 0) As Long
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Declare PtrSafe Function GetForegroundWindow Lib "user32" () As Long
#Else
Declare Function OpenClipboard Lib "user32" (Optional ByVal hwnd As Long = 0) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function EmptyClipboard Lib "user32" () As Long
Declare Function GetForegroundWindow Lib "user32" () As Long
#End If

Const STARTPOS As String = "A5"     ' 貼り付けセル開始位置
Const RANGEPOS As Long = 10         ' 画像貼り付け間隔

Sub スクリーンショットをExcelに貼り付ける()
    Dim cb As Variant
    Dim isLoop As Boolean
    Dim OffsetY As Long
    Dim i As Long
    Dim thisHwnd As Long
    Dim wkHwnd As Long
    Dim ws As Worksheet
    Dim shp As Shape
    
    isLoop = True
    OffsetY = 0
    Set ws = ThisWorkbook.ActiveSheet
    
    clearClipboard
    
    thisHwnd = GetForegroundWindow
    
    'シートに画像があったら削除する
    If ws.Shapes.Count <> 0 Then
    
        If MsgBox("シート内の画像を削除してもいいですか？", vbYesNo) <> vbYes Then
            MsgBox "処理を中断します"
            Exit Sub
        End If
        
        'シート内画像を削除
        For Each shp In ws.Shapes
            If shp.Type = msoPicture Then shp.Delete
        Next shp
    
    End If

    MsgBox "スクショ自動貼り付けを開始します"
    
    'ウインドウ切り替えを待つ
    Do
        wkHwnd = GetForegroundWindow
        If wkHwnd = 0 Then
            wkHwnd = thisHwnd
        End If
        Application.StatusBar = "ウインドウ切り替え待ち中(1/3)"
        DoEvents
    Loop While thisHwnd = wkHwnd
    
    
    'PrintScreenを押されたらエクセルに保存していく
    Application.StatusBar = "自動貼り付け中(2/3)"
    Do While isLoop
        cb = Application.ClipboardFormats
        If cb(1) <> -1 Then
            For i = 1 To UBound(cb)
                If cb(i) = xlClipboardFormatBitmap Then
                    ws.Paste Destination:=ws.Range(STARTPOS).Offset(OffsetY, 0)
                    OffsetY = OffsetY + RANGEPOS
                    clearClipboard
                End If
            Next i
        End If
        
        wkHwnd = GetForegroundWindow
        If thisHwnd = wkHwnd Then
            isLoop = False
            Application.StatusBar = "自動貼り付け終了(3/3)"
        End If
        
        DoEvents
    Loop
    
    MsgBox "自動貼り付けを終了します"
    Application.StatusBar = False
End Sub

Private Sub clearClipboard()
    'クリップボードを空にする。
    OpenClipboard
    EmptyClipboard
    CloseClipboard

End Sub