Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


3751 / 13645 ツリー ←次へ | 前へ→

【60339】クリップボードのキャプチャ画像をシートの背景にしたいのですが すう 09/2/11(水) 8:59 質問[未読]
【60340】Re:クリップボードのキャプチャ画像をシー... 横入り 09/2/11(水) 10:14 発言[未読]
【60341】Re:クリップボードのキャプチャ画像をシー... すう 09/2/11(水) 10:33 質問[未読]
【60342】Re:クリップボードのキャプチャ画像をシー... 横入り 09/2/11(水) 11:17 発言[未読]
【60343】Re:クリップボードのキャプチャ画像をシー... すう 09/2/11(水) 11:29 質問[未読]
【60344】Re:クリップボードのキャプチャ画像をシー... 横入り 09/2/11(水) 12:22 発言[未読]
【60345】Re:クリップボードのキャプチャ画像をシー... すう 09/2/11(水) 12:35 お礼[未読]
【60346】Re:クリップボードのキャプチャ画像をシー... sasa 09/2/11(水) 17:07 回答[未読]
【60348】Re:クリップボードのキャプチャ画像をシー... すう 09/2/11(水) 18:41 お礼[未読]
【60358】Re:クリップボードのキャプチャ画像をシー... Yuki 09/2/12(木) 17:13 発言[未読]
【60367】Re:クリップボードのキャプチャ画像をシー... すう 09/2/13(金) 23:54 お礼[未読]

【60339】クリップボードのキャプチャ画像をシート...
質問  すう  - 09/2/11(水) 8:59 -

引用なし
パスワード
   はじめまして。
初心者ながら、VBAに挑戦しているのですが、
どうにも解決できない問題があり、ご質問いたしました。
よろしくお願いします。

【作りたいソフト】
 お絵かきソフト
【機能】
 1 VBAでデスクトップのキャプチャを取得
 2 取得したキャプチャ画像をシートに貼り付け
 3 キャプチャ画像を2と違うシートの背景に設定
 4 その上にオートシェイプで、図形を描画

いろいろ調べて、下のようなコードを書きましたが、
機能3のキャプチャ画像をシートの背景にすることができません。

最初は機能2で貼り付けたキャプチャ画像を移動できないように
しようとしたのですが、shapeをenableにできずに断念し、画像を
背景にする方向を模索しております。

画像ファイルからではなく、クリップボードから設定したいと思い
No.52689のLindyさんのコードを参考にいたしましたが、うまく行きません。

うまくいかない部分は、***で囲んだ部分です。
なにとぞ、ご教授をお願いいたします。


Sub main()

'-----------------------------------------------------------
' 変数定義
'
  Dim str_ShpSnapshotName As String            '(変数)スナップショットShapeの名称
  Dim str_ShpBkupName As String
  str_ShpSnapshotName = "Snapshot01"            '「Snapshot01」を代入
  str_ShpBkupName = "Bkup01"                '「Bkup01」を代入

'-----------------------------------------------------------
' 初期処理(貼付対象シート・バックアップシートを事前にクリア)
'
  On Error Resume Next                  'Shapeが存在しない場合のエラー回避

  ThisWorkbook.Worksheets("Bkup").Activate
  Worksheets("Bkup").Shapes.SelectAll           'Shapeを全て選択
  Selection.ShapeRange.Delete               'Shapeを全て消去
  Worksheets("Bkup").Cells.Clear

  Worksheets("Snap").Activate
  Worksheets("Snap").Shapes.SelectAll
  Selection.ShapeRange.Delete
  Worksheets("Snap").Cells.Clear

  On Error GoTo 0

'-----------------------------------------------------------
' 写込防止のため、Excelのウィンドウ最小化
'(3秒Wait)
'
  Application.WindowState = xlMinimized
  Application.Wait Now + TimeValue("00:00:03")

'-----------------------------------------------------------
' Snapshot取得
'
  Application.ExecuteExcel4Macro "call(""user32"",""keybd_event"",""JJJJJ"",44,121,1,0)"
  Application.ExecuteExcel4Macro "call(""user32"",""keybd_event"",""JJJJJ"",44,121,3,0)"

'-----------------------------------------------------------
' 「Bkup」シート・「Snap」シートにSnapshot画像をPaste
' Shape.Nameを「Bkup01」・「Snapshot01」に設定
' Excelウィンドウを全画面表示
'
  ThisWorkbook.Worksheets("Bkup").Activate
  Worksheets("Bkup").Range("a1").Select
  Worksheets("Bkup").Paste
  Worksheets("Bkup").Shapes(1).Name = str_ShpBkupName

  Worksheets("Snap").Activate

'*************************************************************************
' クリップボードの画像を背景に設定(1枚のみ)
'
  With Worksheets("Snap")
    .Cells.ColumnWidth = 0.38
    .Cells.RowHeight = 3.75
    .SetBackgroundPicture Worksheets("Bkup").Shapes(str_ShpBkupName)
  End With
'*************************************************************************

  Application.Visible = True
  Application.WindowState = xlMaximized

End Sub

【60340】Re:クリップボードのキャプチャ画像をシ...
発言  横入り  - 09/2/11(水) 10:14 -

引用なし
パスワード
   SetBackgroundPicture メソッドの引数をヘルプで確認してはいかが?

【60341】Re:クリップボードのキャプチャ画像をシ...
質問  すう  - 09/2/11(水) 10:33 -

引用なし
パスワード
   ▼横入り さん:
>SetBackgroundPicture メソッドの引数をヘルプで確認してはいかが?

早速のご回答ありがとうございます。
重ねて質問で申し訳ありませんが、

「文字列型」で「グラフィックファイルを指定」なので無理
との理解でよろしかったでしょうか?

【60342】Re:クリップボードのキャプチャ画像をシ...
発言  横入り  - 09/2/11(水) 11:17 -

引用なし
パスワード
   >「文字列型」で「グラフィックファイルを指定」なので無理
>との理解でよろしかったでしょうか?
あなたのご意見は?

【60343】Re:クリップボードのキャプチャ画像をシ...
質問  すう  - 09/2/11(水) 11:29 -

引用なし
パスワード
   ▼横入り さん:
>>「文字列型」で「グラフィックファイルを指定」なので無理
>>との理解でよろしかったでしょうか?
>あなたのご意見は?

何度もすみません。

不勉強で詳しくはわかりませんが、
おそらく一旦はファイル保存を行い、
そのファイル名を文字列として
指定しなければならないのだろうと思います。

ヘルプは見ていたのですが、何とかファイル保存をせずに
背景にできないかと試行錯誤していたものですから・・・
説明べたで申し訳ありません。

理想としては、クリップボードから貼り付けた画像を
マウスで移動できないようにしたかったのですが
調べた限りでは、まったく実現できなかったのです。
(Chartに貼り付けると、図は動かなくできたのですが
ChartObjectの大きさを図と同じにしても、どうしても
図の周りに余白ができてしまいますし)
何とかならないものでしょうか?

【60344】Re:クリップボードのキャプチャ画像をシ...
発言  横入り  - 09/2/11(水) 12:22 -

引用なし
パスワード
   >ヘルプは見ていたのですが、何とかファイル保存をせずに
>背景にできないかと試行錯誤していたものですから・・・

>理想としては、クリップボードから貼り付けた画像を
>マウスで移動できないようにしたかったのですが
>調べた限りでは、まったく実現できなかったのです。
>(Chartに貼り付けると、図は動かなくできたのですが
>ChartObjectの大きさを図と同じにしても、どうしても
>図の周りに余白ができてしまいますし)
>何とかならないものでしょうか?

了解です。
APIを使えば,クリップボードをファイルに書き付けられますから、
それを利用すればいいでしょう。
どなたか詳しい方がアップされるでしょうから、それを待ちましょう。

【60345】Re:クリップボードのキャプチャ画像をシ...
お礼  すう  - 09/2/11(水) 12:35 -

引用なし
パスワード
   >>理想としては、クリップボードから貼り付けた画像を
>>マウスで移動できないようにしたかったのですが
>>調べた限りでは、まったく実現できなかったのです。
>>(Chartに貼り付けると、図は動かなくできたのですが
>>ChartObjectの大きさを図と同じにしても、どうしても
>>図の周りに余白ができてしまいますし)
>>何とかならないものでしょうか?
>
>了解です。
>APIを使えば,クリップボードをファイルに書き付けられますから、
>それを利用すればいいでしょう。
>どなたか詳しい方がアップされるでしょうから、それを待ちましょう。

横入りさん、何度もありがとうございました。
私もさらにいろいろと試行錯誤してみたいと思います。
お手数をおかけしました。

もし、ほかにもお詳しい方がいらしたら、
ご教授願います。

【60346】Re:クリップボードのキャプチャ画像をシ...
回答  sasa  - 09/2/11(水) 17:07 -

引用なし
パスワード
   >(Chartに貼り付けると、図は動かなくできたのですが
>ChartObjectの大きさを図と同じにしても、どうしても
>図の周りに余白ができてしまいますし)
>何とかならないものでしょうか?

ChartAreaのLeftとTopは0,0ではないので、0になるようずらしてやれば
余白にはならないと思います。
このことについては以下が参考になるでしょう。
E97M053 グラフや表を図形ファイルとして保存する
ht tp://homepage2.nifty.com/kmado/kvba.htm

【60348】Re:クリップボードのキャプチャ画像をシ...
お礼  すう  - 09/2/11(水) 18:41 -

引用なし
パスワード
   ▼sasa さん:
>ChartAreaのLeftとTopは0,0ではないので、0になるようずらしてやれば
>余白にはならないと思います。
>このことについては以下が参考になるでしょう。
>E97M053 グラフや表を図形ファイルとして保存する
>ht tp://homepage2.nifty.com/kmado/kvba.htm

sasaさん、ありがとうございます。
大変参考になりました。

ChartAreaの「.Left、.Top」にあわせなければ
ならなかったんですね。
お恥ずかしいことですが、
ChartObjectに直接Pasteしておりました。

参考ページまで教えていただいて、
本当にありがとうございました。

【60358】Re:クリップボードのキャプチャ画像をシ...
発言  Yuki  - 09/2/12(木) 17:13 -

引用なし
パスワード
   ▼すう さん:
こんにちは。
新しいブックに貼り付けてテストをしてみてください。
Win XP or NT 用です.

Option Explicit
Private Type PicBmp
  Size As Long
  Type As Long
  hBmp As Long
  hPal As Long
  Reserved As Long
End Type

Private Declare Function OpenClipboard Lib "user32" _
        (ByVal hwnd As Long) As Long

Private Declare Function CloseClipboard Lib "user32" _
        () As Long

Private Declare Function GetClipboardData Lib "user32" _
        (ByVal wFormat As Long) 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 OleCreatePictureIndirect Lib _
        "olepro32.dll" _
        (picdesc As PicBmp, _
        RefIID As Any, ByVal fPictureOwnsHandle As Long, _
        ipic As IPictureDisp) As Long

Private Declare Function IIDFromString Lib "ole32" _
        (lpsz As Any, lpiid As Any) As Long

Private Declare Sub keybd_event Lib "user32" _
        (ByVal bVk As Byte, _
        ByValbScan As Byte, _
        ByVal dwFlags As Long, _
        ByVal dwExtraInfo As Long)

Private Const VK_SNAPSHOT = &H2C
Private Const VK_LMENU = &HA4
Private Const KEYEVENTF_EXTENDEDKEY = &H1
Private Const KEYEVENTF_KEYUP = &H2
Private Const IID_IDispatch = "{00020400-0000-0000-C000-000000000046}"
Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4

Sub SaveBitMap()
  Dim OutFileName As String    ' 出力用ファイル名
  OutFileName = "D:\BitMap1.bmp"
  
'  Application.ExecuteExcel4Macro "call(""user32"",""keybd_event"",""JJJJJ"",44,121,1,0)"
'  Application.ExecuteExcel4Macro "call(""user32"",""keybd_event"",""JJJJJ"",44,121,3,0)"
  ' 上記2行の替わりをAPIで (Excel4Macroで出来るなんて知らなかった)
  AppActivate Application.Caption
  keybd_event VK_LMENU, &H56&, KEYEVENTF_EXTENDEDKEY, 0
  keybd_event VK_SNAPSHOT, &H79&, KEYEVENTF_EXTENDEDKEY, 0
  keybd_event VK_LMENU, &H56&, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
  keybd_event VK_SNAPSHOT, &H79&, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
  DoEvents
  Application.Wait [=NOW() + TIMEVALUE("00:00:00.5")]
  ' ビットマップで保存
  SavePicture GetImage(), OutFileName
  ' シート1の背景設定
  Worksheets(1).SetBackgroundPicture OutFileName
End Sub

Function GetImage() As IPictureDisp
  Dim IID(0 To 3) As Long
  Dim bytID()   As Byte
  Dim lngRtn   As Long
  Dim Pic     As PicBmp
  Dim ObjPic   As IPictureDisp
  Dim hBitmap   As Long
  Dim CopyBitmap As Long
  
  bytID = IID_IDispatch & vbNullChar
  IIDFromString bytID(0), IID(0)
  
  OpenClipboard 0
  hBitmap = GetClipboardData(CF_BITMAP)
  If hBitmap = 0 Then
    CloseClipboard
    Exit Function
  End If
  CopyBitmap = CopyImage(hBitmap, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
  CloseClipboard
  With Pic
    .Size = Len(Pic)
    .Type = PICTYPE_BITMAP
    .hBmp = CopyBitmap
  End With
  lngRtn = OleCreatePictureIndirect(Pic, IID(0), 1, ObjPic)
  Set GetImage = ObjPic
End Function

【60367】Re:クリップボードのキャプチャ画像をシ...
お礼  すう  - 09/2/13(金) 23:54 -

引用なし
パスワード
   Yukiさん、ありがとうございます。

ばっちりです。

強制的にビットマップを保存してから呼び出すんですね。
とても参考になりました。
ありがとうございました。

3751 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free