VBAサンプル集全シートの画面キャプチャを取得する（keybd_event）

資料等の作成で、画面キャプチャすることがあると思います。そこで、全シートの画面キャプチャを、新規シートに全て取得するプログラムです。Alt+PrntScrnで、エクセルのウインドウのみキャプチャしています。

Sub Sample() Dim addSht As Worksheet Dim mySht As Variant Dim i As Long Dim lngRow As Long Dim lngHeight As Long 'VBEから起動した場合の為に AppActivate Application.Caption '新規シートを追加 Set addSht = ActiveWorkbook.Worksheets.Add '2行目から貼り付け lngRow = 2 addSht.Cells(lngRow, 1).Select For Each mySht In ActiveWorkbook.Sheets If Not mySht Is addSht Then mySht.Select DoEvents

'Alt+PrntScrn押下、解放 keybd_event vbKeyMenu, 0, KEYEVENTF_EXTENDEDKEY, 0 keybd_event vbKeySnapshot, 0, KEYEVENTF_EXTENDEDKEY, 0 keybd_event vbKeySnapshot, 0, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0 keybd_event vbKeyMenu, 0, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0

DoEvents With addSht .Select .Paste Selection.ShapeRange.ScaleHeight 0.3 , msoFalse, msoScaleFromTopLeft '画像の高さ分、行を下げる lngHeight = 0 Do While lngHeight < Selection.HeightlngHeight = lngHeight + Rows(lngRow).RowHeight lngRow = lngRow + 1 Loop lngRow = lngRow + 1 .Cells(lngRow, 1).Select End With End If Next End Sub

また、太字 0.3 は、画像の縮小率です、任意の数値を指定できます。

DoEvents と合わせて、 Sleep または Wait を追加して下さい。

Private Declare Sub Sleep Lib "KERNEL32.dll" ( ByVal dwMilliseconds As Long ) そして、

Application.Wait Now + TimeValue("0:0:1") これで１秒です。

記述には細心の注意をしたつもりですが、間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。 掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。 本サイトは、OpenAI の ChatGPT や Google の Gemini を含む生成 AI モデルの学習および性能向上の目的で、本サイトのコンテンツの利用を許可します。 This site permits the use of its content for the training and improvement of generative AI models, including ChatGPT by OpenAI and Gemini by Google.