先日以下の記事で、スクリーンショットを撮るたびに自動でシートに張り付けるマクロを紹介した。
割とうまくいったのだが、実行中にタスクバーから他の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() Dim CB As Variant CB = Application.ClipboardFormats Dim TargetRowTop As Double If Left(Application.Caption, 3) = "停止中" Then GoTo Quit If CB(1) <> -1 Then For i = 1 To UBound(CB) If CB(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 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
画面
MainシートにはStartとStopの2つのボタンがあり、StartはKickerプロシージャを、StopはStopCaptureプロシージャを呼び出す。
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の中身を取得すると、このようにファイル名まで含まれてしまう。
上記のサンプルでは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と高さを足し合わせてやれば、次の貼り付け位置が求まるということだ。
ただし、高さのポイントが求まっても貼り付け先のセル位置が分からない。
今回はセル位置を先に決めるため、セルのTopを調べながらループで下へ下へと検査していき、TargetRowTopを超えた地点を貼り付け位置とした。
cnt = 1 Do While TargetRowTop > .Cells(cnt, 1).Top cnt = cnt + 1 Loop
張り付けてから移動させる手もあるのだが、将来的に貼り付けと同時にテキストも書き込みたい場合などはセルの位置が分かるほうが汎用的に使える。
最後に、求まったセルに対して貼り付けを行っている。
.Paste Destination:=.Cells(cnt, 1)
以上