VBA 改良版スクリーンショットを撮るたびに自動でシートに張り付けるマクロ～ OnTimeによる恒常ループ

先日以下の記事で、スクリーンショットを撮るたびに自動でシートに張り付けるマクロを紹介した。

thom.hateblo.jp 割とうまくいったのだが、実行中にタスクバーから他のExcelへ切り替えができないことが判明した。サーバー管理業務でマニュアルがExcelで作られているものがあるので、Excelを閲覧しながら作業できない点はつらい。また、ActiveSheetに張り付けしているため、別のシートがActiveになっていると意図しないところに張り付いてしまう。終了させるためにセルにExitと書く点もあまりイケてない。今回はそのあたりを改良したマクロを作成した。

コード

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

Sub Kicker()
    MsgBox "AutoCaptureを開始します。" & vbNewLine & _
        "終了するにはStopボタンをクリックしてください。", vbInformation
    Application.Caption = "★AutoCapture★"
    Sheets.Add After:=Sheets(Sheets.Count)
    Call AutoCapture
End Sub

Sub AutoCapture()
        DimCBAs VariantCB= Application.ClipboardFormats
        Dim TargetRowTop As Double

        If Left(Application.Caption, 3) = "停止中" Then GoTo Quit
        IfCB(1) <> -1 Then
            Fori= 1 To UBound(CB)
                IfCB(i) = xlClipboardFormatBitmap Then
                    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 = 1
                        Do While TargetRowTop > .Cells(cnt, 1).Top
                            cnt = cnt + 1
                        Loop
                        .Paste Destination:=.Cells(cnt, 1)
                    End With
                    'クリップボードを空にする。
                    OpenClipboard
                    EmptyClipboard
                    CloseClipboard
                End If
            NextiEnd 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

画面

MainシートにはStartとStopの2つのボタンがあり、StartはKickerプロシージャを、StopはStopCaptureプロシージャを呼び出す。
f:id:t-hom:20151129120653p:plain

OnTimeループの解説

まず、Excelブックの切り替えができない点であるが、これはDoEventsを挟んでも無理なようだ。したがって、Do While文でのループを辞め、OnTimeループに切り替えた。 OnTimeはマクロの実行を予約するApplicationのメソッドである。次のような書式で呼び出す。

Application.OnTime 時刻, マクロ名

次のマクロはOnTimeを使った繰り返し処理のサンプルである。実行するとイミディエイトウインドウに現在時刻を出力した後、5秒後に自身を再度実行するように予約する。

Sub OnTimeTest()
    Debug.Print Now
    Application.OnTime DateAdd("s", 5, Now), "OnTimeTest"
End Sub

これを止めるには、実行中にApplication～をコメントアウトすればよい。一見、再帰と似ているが、大きく異なるのは自分で呼び出しを行っているわけではなく、Excelに呼び出しを託してマクロを一旦終了している点である。マクロは終了しているので、Excelの操作は自由に行える。ただし、OnTimeでは1秒先未満の予約は難しいようで、これまでスクリーンショットを撮ってから張り付くまで一瞬だったのが、若干のラグが発生する。実用性に問題はないので、これは諦めることにした。さて、終了時に毎回コメントアウトでは面倒くさいので、何か終了の仕組みを組み込む必要がある。前回はActiveSheetのA1セルにExitが入っているかどうかで判定していたが、今回はApplicationのCaptionを利用することにした。次のコードを実行すると、Excelのタイトルを変更できる。

Application.Caption = "停止中"

元に戻すときは、空文字列をセットすれば良い。

Application.Caption = ""

この仕組みを終了条件に使ったのが次のサンプルである。

Sub OnTimeTest()
    If Left(Application.Caption, 3) = "停止中" Then GoTo Quit
    Debug.Print Now
    Application.OnTime DateAdd("s", 5, Now), "OnTimeTest"
    Exit Sub
Quit:
    Application.Caption = ""
    MsgBox "OnTimeTestを終了しました。", vbInformation
End Sub

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

Stopperを実行するとタイトルに停止中がセットされ、OnTimeTestで停止中を検知すると次回の実行予約を行わずにキャプションを元に戻して終了する。 Application.Captionプロパティで注意したいのは、セットする文字列と取得される文字列が異なる点である。例えば﹁停止中﹂と設定した際、Application.Captionの中身を取得すると、このようにファイル名まで含まれてしまう。 f:id:t-hom:20151129115346p:plain

上記のサンプルではLeft関数で左から3文字を切り出すことで停止中を検知している。では、OnTimeTestで、最初の実行時にメッセージを表示させるにはどうするか。これは簡単で、OnTimeTestを呼び出す別のプロシージャを作成し、そこに開始メッセージを含めればよい。

Sub Kicker()
    MsgBox "OnTimeTestを開始します。", vbInformation
    Application.Caption = "実行中"
    Call OnTimeTest
End Sub

プログラムで別のプログラムを起動させることを﹁キックする﹂という。これはOnTimeTestをキックするためのプロシージャなのでキッカーという名称にした。

貼り付け場所の解説

まず、キャプチャマクロのKickerでは貼り付け先を確保するため実行時に新しいシートを増やしている。

Sheets.Add After:=Sheets(Sheets.Count)

AutoCaptureの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 = 1
    Do While TargetRowTop > .Cells(cnt, 1).Top
        cnt = cnt + 1
    Loop
    .Paste Destination:=.Cells(cnt, 1)
End With

With文の中身の最初のIf文は、対象シートに含まれる最終のシェイプを割り出して、その終点の高さを求めている。

    If .Shapes.Count > 0 Then
        With .Shapes(.Shapes.Count)
            TargetRowTop = .Top + .Height
        End With
    Else
        TargetRowTop = 0
    End If

つまり、このマクロでは最後に張り付けられたシェイプが一番下にくるので、そのTopと高さを足し合わせてやれば、次の貼り付け位置が求まるということだ。 f:id:t-hom:20151129122028p:plain

ただし、高さのポイントが求まっても貼り付け先のセル位置が分からない。今回はセル位置を先に決めるため、セルのTopを調べながらループで下へ下へと検査していき、TargetRowTopを超えた地点を貼り付け位置とした。

    cnt = 1
    Do While TargetRowTop > .Cells(cnt, 1).Top
        cnt = cnt + 1
    Loop

張り付けてから移動させる手もあるのだが、将来的に貼り付けと同時にテキストも書き込みたい場合などはセルの位置が分かるほうが汎用的に使える。最後に、求まったセルに対して貼り付けを行っている。

.Paste Destination:=.Cells(cnt, 1)

以上

t-hom’s diary

主にVBAネタを扱っているブログ…とも言えなくなってきたこの頃。

VBA 改良版スクリーンショットを撮るたびに自動でシートに張り付けるマクロ～ OnTimeによる恒常ループ

コード

画面

OnTimeループの解説

貼り付け場所の解説