クリップボード貼り付け

Private Declare PtrSafe Function OpenClipboard Lib "USER32" (Optional ByVal hwnd As Long = 0) As Long
Private Declare PtrSafe Function CloseClipboard Lib "USER32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "USER32" () As Long
Private Declare PtrSafe Function GetInputState Lib "USER32" () As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long)

Dim isContinue_ As Boolean
Dim targetSheet_ As Worksheet
Dim pasteRow_ As Integer
Const pasteCol_ As Integer = 2

Sub Kicker()
        
    MsgBox "AutoCaptureを開始"

    ' 貼り付けシート習得と貼り付け開始行の取得
    Call Preparation
    Call AutoCapture
End Sub

Private Sub AutoCapture()
    Dim cbFormat As Variant
    Dim sh As Worksheet
    
    'クリップボードの形式取得する。
    cbFormat = Application.ClipboardFormats
    
    If cbFormat(1) <> -1 Then
        
        targetSheet_.Paste Destination:=targetSheet_.Cells(pasteRow_, pasteCol_)
        
        ' 貼り付け行更新
        UpdateRow (cbFormat)
        
        'クリップボードを空にする。
        OpenClipboard
        EmptyClipboard
        CloseClipboard
    End If
    
    DoEvents
    If isContinue_ = True Then
        Application.OnTime DateAdd("s", 1, Now), "AutoCapture"
    End If
    'Application.ScreenUpdating = True
    
End Sub

Private Sub Preparation()
    Dim ws As Worksheet, isExist As Boolean, name As String
    
    ' 初期化
    pasteRow_ = 1
    isContinue_ = True
    
    'クリップボードを空にする。
    OpenClipboard
    EmptyClipboard
    CloseClipboard
    
    ' 貼り付けシートの準備
    With ThisWorkbook
        
        name = .Sheets("menu").Cells(8, 7).Value
        For Each ws In .Worksheets
            If ws.name = name Then isExist = True
        Next ws
    
        If isExist = True Then
            Set targetSheet_ = .Sheets(name)
            
            With targetSheet_
                If IsEmpty(.Cells(1, 1)) Then
                    pasteRow_ = 1
                Else
                    pasteRow_ = .Cells(1, 1).Value
                End If
            End With
        Else
            ' 新規シートに貼り付け
            
            Worksheets.Add After:=Worksheets(Worksheets.Count)
            ActiveWindow.View = xlPageBreakPreview
            
            .ActiveSheet.name = name
            Set targetSheet_ = .ActiveSheet
            
            .Sheets("menu").Select
        End If

    End With
    

End Sub

Sub Kill()
    isContinue_ = False
    
    ' 終了時に再開時用に貼り付け行をセルに保管
    With targetSheet_.Cells(1, 1)
        .Locked = False
        .Font.ColorIndex = 2 ' 白
        .Value = pasteRow_
        .Locked = True
    End With
    
    MsgBox "AutoCaptureを終了"
End Sub

Private Function UpdateRow(cbFormat As Variant)
    Dim isImg As Boolean
    isImg = False
    
    With targetSheet_
        ' 画像の場合、画像の高さから次の貼り付け位置の更新
        For Each fmt In cbFormat
            If fmt = xlClipboardFormatBitmap Then
                lastImg = .Shapes.Count
                imgHeighet = .Shapes(lastImg).Height
                cellHeight = .Cells(1, 1).RowHeight
                
                pasteRow_ = pasteRow_ _
                        + Round(imgHeighet / cellHeight) _
                        + 3
                        
                isImg = True
            End If
        Next
        
        ' 画像以外の場合
        If isImg = False Then
            With .Cells(pasteRow_, pasteCol_).CurrentRegion
                pasteRow_ = .Row + .Rows.Count
            End With
        End If
    
    End With
End Function

Sub SaveSheet()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
     
    '新規ブックのファイルパスを設定
    Dim filePath As String
    filePath = ThisWorkbook.Sheets("menu").Cells(9, 7).Value
    
    ' 新規ブックを作成する
    With Workbooks.Add
     
        For Each sh In ThisWorkbook.Worksheets
            If sh.name <> "menu" Then
                sh.Copy After:=.Sheets(.Worksheets.Count)
            End If
        Next
        .Sheets("Sheet1").Delete
        
        ' 新規作成したブックを保存する
        ' 拡張子が.xlsxの場合はxlOpenXMLWorkbook
        .SaveAs Filename:=filePath, _
                FileFormat:=Excel.XlFileFormat.xlOpenXMLWorkbook
         
        ' 新規作成したファイルを閉じる
        .Close
    End With
     
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub