【VBA】 Alt＋PrintScreenにてアクティブウィンドウのスクショを貼付する方法

下記のVBAコードをご覧ください。
こちらは、動きます。

内容は、プリントスクリーン【パソコンの全画面】をスクショして
エクセルに貼付します。

自分のやりたことは、全画面ではなく、アクティブなウィンドウだけを
スクショしてエクセルに貼付したいです。

手動でやるなら、　Alt＋「PrtSc (PrintScreen)」でできます。
これをVBAにて出来ないでしょうか。

ご存じの方いましたら、教えて下さい。


【コード】
'キーボードイベント用のライブラリ読み込み
Private Declare PtrSafe Sub keybd_event Lib "user32" ( _
ByVal bVk As Byte, _
ByVal bScan As Byte, _
ByVal dwFlags As Long, _
ByVal dwExtraInfo As Long _
)

Sub スクショ貼付()
Set ws = ActiveSheet
keybd_event vbKeySnapshot, 0&, fKEYDOWN, 0&
keybd_event vbKeySnapshot, 0&, fKEYUP, 0&
Application.Wait Now() + TimeValue("00:00:01")
With ws
.Range("A1").Select
.Paste
'Selection.Copy
Set sp1 = .Shapes(.Shapes.Count)
End With
End Sub

No.4 回答者： Qchan1962 回答日時： 2022/12/13 00:52

>同じように、するコードをご指導、お願いできませんでしょうか。

クロームのウィンドウ特定する部分はコメントに入れてあります

'ウィンドウタイトルに"Google Chrome"が含まれているか'
If InStr(MyName, CY_SEARCH_NAME) > 0 Then　

実行プロシージャ最初に　変数CY_SEARCH_NAME = "Google Chrome"　としていますね
他のWindowに対して制御する場合は、これを変更すれば良いです

同様に実行プロシージャ最後に
CY_SEARCH_NAME = ThisWorkbook.Windows(1).Caption
Call EnumWindows(AddressOf GetProc, 0)
を実行しています
この実行を行わないとThisWorkbookのWindowが最前面に表示されません

API　Functionは長ったらしくありますが実行プロシージャはシンプルです
ご質問者様はVBAを作る側でしょうから・・
単に使う側になって欲しくはないのでプロシージャコードは割愛しますが
悪しからず（たぶん簡単に出来ると思いますので試してください）

この回答へのお礼

いつも、ご指導ありがとうございます。試してみます。

お礼日時：2022/12/13 01:33

No.3 回答者： Qchan1962 回答日時： 2022/12/09 19:15

クロームのウィンドウをスクショしたいと言う事ですね

ボタンから実行　Sheets(1)に貼り付け　サイズ変更は別スレでしたね
オーナーwindowですが・・長いので分けます

Option Explicit
'WinAPI宣言'
#If Win64 Then
'【GetWindow関数】オーナーフォームハンドル取得
Declare PtrSafe Function GetWindow Lib "user32" ( _
ByVal hwnd As LongPtr, _
ByVal wCmd As Long) As LongPtr
'【GetWindowText関数】キャプション取得'
Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As LongPtr
'【SetForegroundWindow関数】
Declare PtrSafe Sub SetForegroundWindow Lib "user32" (ByVal hwnd As LongPtr)
Dim hwnd As LongPtr
#Else
'【GetWindow関数】オーナーフォームハンドル取得
Declare Function GetWindow Lib "user32" _
(ByVal hwnd As Long, ByVal wCmd As Long) As Long
'【GetWindowText関数】キャプション取得'
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
'【SetForegroundWindow関数】
Declare Sub SetForegroundWindow Lib "user32" (ByVal hwnd As Long)
Dim hwnd As Long
#End If

'ウィンドウ列挙'
Declare Function EnumWindows Lib "user32" ( _
ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long

Private Declare PtrSafe Sub keybd_event Lib "user32" ( _
ByVal bVk As Byte, _
ByVal bScan As Byte, _
ByVal dwFlags As Long, _
ByVal dwExtraInfo As Long _
)
Private Const fKEYDOWN = &H1
Private Const fKEYUP = &H1 Or &H2
Private Const ERROR_SUCCESS = &H0
'定数
Public Const GW_OWNER = 4
Public Const WM_CLOSE = &H10
'変数
Dim CY_SEARCH_NAME As String
Public Function GetProc(ByVal hwnd As Long, lParam As Long) As Boolean
Dim MyName As String * 128
Dim ret As Long
MyName = ""
'ウィンドウタイトルを取得'
ret = GetWindowText(hwnd, MyName, Len(MyName))
'オーナーウィンドウかの判定'
If GetWindow(hwnd, GW_OWNER) = 0 Then
If ret <> 0 Then
'ウィンドウタイトルに"Google Chrome"が含まれているか'
If InStr(MyName, CY_SEARCH_NAME) > 0 Then
SetForegroundWindow hwnd
DoEvents 'OSによって処理されるように制御を戻す
GetProc = False
Exit Function
End If
End If
End If
GetProc = True
End Function

Sub スクショ貼付()　'他のシートボタン登録
CY_SEARCH_NAME = "Google Chrome"
Call EnumWindows(AddressOf GetProc, 0)

'vb定数:16進数:キー
'vbKeyMenu:&H12:Alt
'vbKeySnapshot :&H2C:PrintScreen
keybd_event vbKeyMenu, 0, fKEYDOWN, 0&
keybd_event vbKeySnapshot, 0, fKEYDOWN, 0&
DoEvents 'OSによって処理されるように制御を戻す
keybd_event vbKeyMenu, 0, fKEYUP, 0&
keybd_event vbKeySnapshot, 0, fKEYUP, 0&
Application.Wait Now() + TimeValue("00:00:01")

Dim ws As Worksheet
Dim sp1 As Shape
ThisWorkbook.Activate
Set ws = Worksheets(1)
With ws
.Select
.Range("A1").Select
.Paste
Set sp1 = .Shapes(.Shapes.Count)
End With
'ExcelBook
CY_SEARCH_NAME = ThisWorkbook.Windows(1).Caption
Call EnumWindows(AddressOf GetProc, 0)

End Sub

この回答へのお礼

めちゃくちゃすごいコードありがとうございました。
ちゃんと、アクティブになっているクロームだけ
スクショが貼付られます。

Qchan1962様、今回クロームがアクティブになっているもの
について、教授いただきましたが

これをインターネットエクスプローラー【エッジではなく昔のです】
にて、同じように、するコードをご指導、お願いできませんでしょうか。

お手すきな時に宜しくお願いいたします。

お礼日時：2022/12/12 22:01

No.2 回答者： Qchan1962 回答日時： 2022/12/09 01:33

こんばんは、途中まで書いて落ちてしまいました書き直しします

ご質問のコードには　Altキーへの命令がありません（それを聞きたいのかな）
また、Altキー+PrintScreenキーを押下してすぐに戻すと正しくOSで処理できない可能性があります

簡単にコード内に説明を付けサンプルします
Private Declare PtrSafe Sub keybd_event Lib "user32" ( _
ByVal bVk As Byte, _
ByVal bScan As Byte, _
ByVal dwFlags As Long, _
ByVal dwExtraInfo As Long _
)
Private Const fKEYDOWN = &H1
Private Const fKEYUP = &H1 Or &H2
Dim ws As Worksheet
Dim sp1 As Shape

Sub スクショ貼付()
'vb定数:16進数:キー
'vbKeyMenu:&H12:Alt
'vbKeySnapshot :&H2C:PrintScreen
keybd_event vbKeyMenu, 0, fKEYDOWN, 0&
keybd_event vbKeySnapshot, 0, fKEYDOWN, 0&
DoEvents 'OSによって処理されるように制御を戻す
keybd_event vbKeyMenu, 0, fKEYUP, 0&
keybd_event vbKeySnapshot, 0, fKEYUP, 0&
Application.Wait Now() + TimeValue("00:00:01")

Set ws = ActiveSheet
With ws
.Range("A1").Select
.Paste
Set sp1 = .Shapes(.Shapes.Count)
End With
End Sub

まだ課題が残りそうですね
アクティブとは移ろうな状態です
ボタンからVBAを実行するとおそらくはそのボタンが設置されたシートを
表示するウィンドウがアクティブウィンドウです
他のアプリケーションウィンドウをスクショしたくてもどのようにVBAを実行すれば良いのか・・

ボタンからVBAを実行
ウィンドウを名前などで探し（特定し）アクティブにして
スクショ・・シートに貼り付け・・

課題の参考例
WindowsAPI　ウインドウを取得
https://officevba.info/example-findwindow/
Windowオブジェクトを取得する
https://www.officepro.jp/excelvba/window/index1. …

この回答へのお礼

いつも回答ありがとうございます。
出来ました。ALT+PrintScreeen。

たしかに、マクロが貼ってあるボタンのエクセルが
最後、アクティブとなり、スクショされますね。

当初の目的の、例えば、ウィンドウがエクセル含め３つ
あって、クロームのウィンドウがアクティぶになっている。

同じウィンドウだけをスクショしたくても、最後には
マクロがあるエクセルがアクティブになって、スクショ
されますねえ。

ヒントを例、さがしてみます。

お礼日時：2022/12/09 07:48

No.1 回答者： Chown 回答日時： 2022/12/08 22:16

こちらが参考になりそうです。

https://yuworks.blog/vba-screenshot/

この回答へのお礼

同サイト参考になります。ありがとうございます。

お礼日時：2022/12/09 07:49