Excelのスクリーンショットについて

質問

Excelのプリントスキャンについて教えて下さい。

デジカメとPCをHDMIで接続します。
当然PCの画面上にはデジカメで映してる映像が映されています。

その画面のみをプリントスキャンし、Excelの結合してあるアクティブセルに
セルのサイズに合わせて貼り付けを行いたいです。

マクロを組んで、プリントスキャンを行いましたが
Excelシートが前面にある状態でないとボタンが機能しない為
デジカメの画面がプリントスキャンできませんでした。

またExcelの【挿入】→【スクリーンショット】から
使用出来るウィンドを選択し、挿入ができますがそのままの画面サイズで
貼り付けられてしまう為、目的が達成で来ません。

一番いいのは、マクロ実行ボタンを押す→スクリーンショットの使用できるウィンドが表示される
→自分でウィンドを選択する→アクティブの結合されているセルにそのセルサイズに合わせて画像が貼り付けられる
→選択したスクリーンショットをJPG画像として指定いたフォルダに保存する

という形が出来れば一番いいです。
このような方法が可能でしょうか？

回答No.4

mitarashi

#2-3です。
#3のURLの切り貼りに失敗して、末尾のLが落ちていました。下記が正しいです。申し訳ありませんでした。
http://okwave.jp/qa/q8743074/a24307580.html

回答No.3

mitarashi

#2です。
ご質問文を読み返してみて、投稿した写真同様ピンぼけだったかと気になりました。
PCとデジカメはHDMIで接続して画像をPCに取り込めるのでしょうか？ノートPC等についているHDMI端子は一般に出力専用の様です。USBで接続してWebカメラ的に使えるデジカメもある様ですが、当方の所有しているNikon製コンデジでは無理でした。
とりあえずWebカメラからの取込、ワークシート貼り付けは実現できました。
#2で紹介した2のコードを取り込んで、下記コードの前半を上の方の
''''''''''''''''''''''''''''''
'
' CreateBitmapPicture
の上に貼り付けます。後半は、一番下に貼り付けて下さい。
CopyPictureOfCameraViewerを実行すると、ActiveCellにWebカメラの画像を貼り付けます。
結合セルに貼り付けについては、長くなるので触れませんが、http://okwave.jp/qa/q8743074/a24307580.htm
あたりがご参考になると思います。
☆前半
'追加
Private Type POINT
x As Long
y As Long
End Type

Private Const PICTYPE_BITMAP = 1
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const CF_BITMAP = 2

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetClientRect Lib "user32.dll" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINT) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long

☆後半
Public Sub CopyPictureOfCameraViewer()
Dim pic As IPictureDisp
Dim r As Long

Set pic = CaptureCameraViewerWindow()
r = CopyBitmapPictureToCB(pic)
With ActiveSheet
.Paste
With .Shapes(.Shapes.Count) '真面目にやるには縦横比とか配慮が必要ですが、サンプルです。
.Left = ActiveCell.Left
.Top = ActiveCell.Top
.Width = ActiveCell.Width
.Height = ActiveCell.Height
.Cut
End With
End With
'ファイル容量増大を防ぐためJPEG形式に変換して貼り付ける
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
End Sub

Public Function CaptureCameraViewerWindow() As IPictureDisp
Dim r As Long
Dim strWindowText As String
Dim lngHWnd As Long
Dim myPoint As POINT
Dim lngWnd As Long
Dim RectActive As RECT
Dim RectForm As RECT

'取得するウィンドウのキャプションを設定します
'この名前はCameraViewerの場合なので、実際のアプリケーションに合わせる必要があります
strWindowText = "Capture [0]"
lngWnd = FindWindow(vbNullString, strWindowText)
If lngWnd = 0 Then Exit Function

r = GetWindowRect(lngWnd, RectForm)
With myPoint
.x = RectForm.Left
.y = RectForm.Top
End With
r = ScreenToClient(lngWnd, myPoint)
r = GetClientRect(lngWnd, RectActive)
Set CaptureCameraViewerWindow = CaptureWindow(lngWnd, False, Abs(myPoint.x), Abs(myPoint.y), RectActive.Right - RectActive.Left, RectActive.Bottom - RectActive.Top)
End Function

' ビットマップ形式のPictureをクリップボードにコピー
Private Function CopyBitmapPictureToCB(ByVal pic As Object) As Boolean
Dim hBmp As Long
If pic Is Nothing Then Exit Function
If pic.Type <> PICTYPE_BITMAP Then Exit Function
hBmp = pic.handle
hBmp = CopyImage(hBmp, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
If hBmp = 0 Then Exit Function
If OpenClipboard(0) Then
EmptyClipboard
If SetClipboardData(CF_BITMAP, hBmp) Then
hBmp = 0
CopyBitmapPictureToCB = True
End If
CloseClipboard
End If
If hBmp Then DeleteObject hBmp
End Function

Private Function GetDesktopPath() As String
Dim wScriptHost As Object, strInitDir As String
Set wScriptHost = CreateObject("Wscript.Shell")
GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
Set wScriptHost = Nothing
End Function

お礼

お礼が遅くなり申し訳ありません。

まず、私の確認不足でカメラとPCのHDMI接続の件
申し訳ございませんでした。

ご指摘の通り、PCのHDMIは出力のみでした。

なので私が希望していたことはできませんでした。

教えて頂いたwebカメラを使用しての方法で試してみようと思うのですが
webカメラが手元にない為、すぐには試すことが出来ないので
webカメラを入手次第、頂いたマクロを使用してみたいと思います。

マクロが無事に動きましたら、またお礼の報告をさせて頂きます。

回答No.2

mitarashi

面白そうなのでやってみました。
１．試験のために、USBカメラ画像を表示できるフリーソフトを導入しました。
http://kougaku-navi.net/backyard/index.html
にある、CameraViewerというもので、インストール不要でレジストリを汚しません。
２．調べていて、次の記事をみつけました。
http://chaigon.blog15.fc2.com/blog-entry-6.html
これを改造して、指定したWindowCaptionのWindowのクライアント領域（枠の内側）だけをbmpで保存する迄は出来ました。クリップボードに取り込んでワークシートに貼り付けるのは明晩のテーマとさせていただきます。
なお、画面キャプチャしますので、CameraViewerのウィンドウは、Activeで無くても良いですが、他のウィンドウに隠れていない必要があります。
WinAPIの宣言や、構造体の追加は後日としますが、さわりだけ載せます。２のコードに追加する事になります。
しょうも無い例ですが、取込例も添付します。ご参考まで。
Public Sub SavePictureOfCameraViewer()
Dim pic As IPictureDisp
Set pic = CaptureCameraViewerWindow()
Call SavePicture(pic, GetDesktopPath & "\cameraviewer.bmp")
End Sub

Public Function CaptureCameraViewerWindow() As IPictureDisp
Dim r As Long
Dim strWindowText As String
Dim lngHWnd As Long
Dim myPoint As POINT
Dim lngWnd As Long
Dim RectActive As RECT
Dim RectForm As RECT

'取得するウィンドウのキャプションを設定します
strWindowText = "Capture [0]"

lngWnd = FindWindow(vbNullString, strWindowText)
If lngWnd = 0 Then Exit Function

r = GetWindowRect(lngWnd, RectForm)
With myPoint
.x = RectForm.Left
.y = RectForm.Top
End With
r = ScreenToClient(lngWnd, myPoint)
r = GetClientRect(lngWnd, RectActive)
Set CaptureCameraViewerWindow = CaptureWindow(lngWnd, False, Abs(myPoint.x), Abs(myPoint.y), RectActive.Right - RectActive.Left, RectActive.Bottom - RectActive.Top)
End Function
Private Function GetDesktopPath() As String
Dim wScriptHost As Object, strInitDir As String
Set wScriptHost = CreateObject("Wscript.Shell")
GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
Set wScriptHost = Nothing
End Function

補足

ご回答ありがとうございます。

もうすご過ぎてなにがなんだか分かりませんが・・・

とりあえず、教えて頂いたCameraViewerを取りました。

マクロの方は、２のコードに追加といお話しでしたが
どこに追加すればいいのかよく分かっておりません。

載せて頂いたコードが、すで２のコードに追加したものという
ことなのでしょうか？

理解できず申し訳ございません。

回答No.1

aokii

Excelの【挿入】→【スクリーンショット】から使用出来るウィンドを選択し、挿入ができたら、そのウィンド画像を右クリックして「トリミング」をクリックしてトリミングしてみてください。

お礼

その方法もできるのですが、いちいちトリミングが面倒ですので、他の方法を考えております。
ご回答頂き、ありがとうございます。