LoginSignup
0
0

More than 1 year has passed since last update.

@hiropop_08(Kane)

画像やキャプチャを自動で貼り付けるマクロ（自分用）

Last updated at Posted at 2022-02-08

マクロ本体(ユーザーフォーム有り、無しは下に掲載)

Microsoft Forms 2.0 Object Libraryを参照設定に入れること

色々と無理やりやってるから後でちょっと変える
いらないからセルコピーは無視してる

Module
Option Explicit

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

Dim i As Long
Dim cnt As Long

Sub Kicker()
    Call ShowForm
    Application.Caption = ""
    Call AutoCapture
End Sub

Sub AddKicker()
    Sheets.Add After:=Sheets(Sheets.Count)
    Call ShowForm
    Application.Caption = ""
    Call AutoCapture
End Sub

Sub AutoCapture()
        Dim CB As Variant
        CB = Application.ClipboardFormats
        Dim TargetRowTop As Double
        Dim xlLastRow As Long       'Excel自体の最終行
        Dim LastRow As Long         '最終行

        If Right(Application.Caption, 3) = "停止中" Then GoTo Quit

        If CB(1) <> -1 Then 'クリップボードに値があるか
            For i = 1 To UBound(CB)
                If CB(i) = xlClipboardFormatText Then Exit For  'テキスト、セルの場合、貼り付けしない

                If CB(i) = xlClipboardFormatBitmap Then
                    captureExetute.nowMode.Caption = "貼り付け中"
                    'マクロ高速化
                    With Application
                        .ScreenUpdating = False
                        .EnableEvents = False
                        .Calculation = xlCalculationManual
                    End With

                    With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                        If .Shapes.Count > 0 Then  '貼り付けられている画像があるか
                            With .Shapes(.Shapes.Count)
                                TargetRowTop = .Top + .Height  '貼り付けられている高さを取得
                            End With
                        Else
                            TargetRowTop = 0
                        End If
                        cnt = 2
                        Do While TargetRowTop > .Cells(cnt, 1).Top '貼り付けられている画像がセル目なのか判定
                            cnt = cnt + 1
                        Loop
                        xlLastRow = .Cells(Rows.Count, 1).Row  'Excelの最終行を取得
                        LastRow = .Cells(xlLastRow, 2).End(xlUp).Row   'B列の最終行を取得

                        If cnt > LastRow Then '貼り付けられている画像のセルより入力されている文字のほうがセルが後か判定
                            .Paste Destination:=.Cells(cnt + 1, 2) '貼り付けられている画像のほうがセルが後の場合
                        Else
                            .Paste Destination:=.Cells(LastRow + 3, 2) '入力されている文字のほうがセルが後の場合
                        End If
                    End With
                    'クリップボードを空にする。
                    OpenClipboard
                    EmptyClipboard
                    CloseClipboard
                    'マクロ高速化
                    With Application
                        .ScreenUpdating = True
                        .EnableEvents = True
                        .Calculation = xlCalculationAutomatic
                    End With

                    captureExetute.nowMode.Caption = "実行中"
                    '再実行
                    DoEvents
                    Application.OnTime Now, "AutoCapture"
                    Exit Sub
                End If
            Next i
        End If
        '再実行
        DoEvents
        Application.OnTime DateAdd("s", 1, Now), "AutoCapture"
        Exit Sub
Quit:
    MsgBox "AutoCaptureを停止しました。", vbInformation
    Application.Caption = ""
End Sub

''ユーザーフォームの表示
Sub ShowForm()
    Load captureExetute
    captureExetute.StartUpPosition = 2
    captureExetute.Show vbModeless
    captureExetute.WindowHideButton.Value = False
    captureExetute.WindowShowButton.Value = True
End Sub

Sub StopCapture()
    Application.Caption = "停止中"
End Sub

作成ボタンはKicker、AddKicker、StopCapture用に3つ
Kicker：既存のシートに貼り付け用
AddKicker：新しいシートに貼り付け用
StopCapture：止める用

ユーザーフォーム

captureExetute
Option Explicit

'ユーザーフォームを常に前にする設定
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function SetWindowPos Lib "user32" _
(ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Const HWND_TOPMOST As Long = -1
Private Const SWP_NOSIZE As Long = &H1&
Private Const SWP_NOMOVE As Long = &H2&

Dim topRow As Long
Dim leftRow As Long

Private Sub UserForm_Initialize()
    PauseButton.Visible = True
    ReStartButton.Visible = False
End Sub

Sub UserForm_Activate()
'ユーザーフォームを常に前にする
Dim hWnd As Long
hWnd = FindWindow(vbNullString, Me.Caption)
Call SetWindowPos(hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End Sub

Private Sub ExitButton_Click()
    If ThisWorkbook.Windows(1).WindowState = xlMinimized Then ThisWorkbook.Windows(1).WindowState = xlNormal
    Call StopCapture
    Unload Me
End Sub

Private Sub PauseButton_Click()
    PauseButton.Visible = False
    ReStartButton.Visible = True
    nowMode.Caption = "停止中"
    Call StopCapture
End Sub

Private Sub ReStartButton_Click()
    PauseButton.Visible = True
    ReStartButton.Visible = False
    nowMode.Caption = "実行中"
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Activate
    Application.Caption = ""
    Call AutoCapture
End Sub

Private Sub WindowShowButton_Click()
    If ThisWorkbook.Windows(1).WindowState = xlMinimized Then ThisWorkbook.Windows(1).WindowState = xlNormal
    WindowHideButton.Value = False
    WindowShowButton.Value = True

    Call ShowMe(Me.Top, Me.Left)
End Sub

Sub WindowHideButton_Click()
    ThisWorkbook.Windows(1).WindowState = xlMinimized
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'フォームの閉じるボタンの無効化
If CloseMode = 0 Then Cancel = True
End Sub

Sub ShowMe(topRow As Long, leftRow As Long)
    Load Me
    With Me
        .StartUpPosition = 0
        .Top = topRow
        .Left = leftRow
        .Show vbModeless
    End With
End Sub

ユーザーフォーム作りたくないならこれこぴればOK

ボタンはマクロ本体の下に書いてあるよ

Module
Option Explicit

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

Dim i As Long
Dim cnt As Long

Sub Kicker()
    Application.Caption = ""
    Call AutoCapture
End Sub

Sub AddKicker()
    Sheets.Add After:=Sheets(Sheets.Count)
    Application.Caption = ""
    Call AutoCapture
End Sub

Sub AutoCapture()
        Dim CB As Variant
        CB = Application.ClipboardFormats
        Dim TargetRowTop As Double
        Dim xlLastRow As Long       'Excel自体の最終行
        Dim LastRow As Long         '最終行

        If Right(Application.Caption, 3) = "停止中" Then GoTo Quit

        If CB(1) <> -1 Then 'クリップボードに値があるか
            For i = 1 To UBound(CB)
                If CB(i) = xlClipboardFormatText Then Exit For  'テキスト、セルの場合、貼り付けしない

                If CB(i) = xlClipboardFormatBitmap Then
                    'マクロ高速化
                    With Application
                        .ScreenUpdating = False
                        .EnableEvents = False
                        .Calculation = xlCalculationManual
                    End With

                    With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                        If .Shapes.Count > 0 Then  '貼り付けられている画像があるか
                            With .Shapes(.Shapes.Count)
                                TargetRowTop = .Top + .Height  '貼り付けられている高さを取得
                            End With
                        Else
                            TargetRowTop = 0
                        End If
                        cnt = 2
                        Do While TargetRowTop > .Cells(cnt, 1).Top '貼り付けられている画像がセル目なのか判定
                            cnt = cnt + 1
                        Loop
                        xlLastRow = .Cells(Rows.Count, 1).Row  'Excelの最終行を取得
                        LastRow = .Cells(xlLastRow, 2).End(xlUp).Row   'B列の最終行を取得

                        If cnt > LastRow Then '貼り付けられている画像のセルより入力されている文字のほうがセルが後か判定
                            .Paste Destination:=.Cells(cnt + 1, 2) '貼り付けられている画像のほうがセルが後の場合
                        Else
                            .Paste Destination:=.Cells(LastRow + 3, 2) '入力されている文字のほうがセルが後の場合
                        End If
                    End With
                    'クリップボードを空にする。
                    OpenClipboard
                    EmptyClipboard
                    CloseClipboard
                    'マクロ高速化
                    With Application
                        .ScreenUpdating = True
                        .EnableEvents = True
                        .Calculation = xlCalculationAutomatic
                    End With

                    '再実行
                    DoEvents
                    Application.OnTime Now, "AutoCapture"
                    Exit Sub
                End If
            Next i
        End If
        '再実行
        DoEvents
        Application.OnTime DateAdd("s", 1, Now), "AutoCapture"
        Exit Sub
Quit:
    MsgBox "AutoCaptureを停止しました。", vbInformation
    Application.Caption = ""
End Sub

Sub StopCapture()
    Application.Caption = "停止中"
End Sub
0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0