|
はじめまして。
初心者ながら、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
|
|