Excel VBA質問箱 IV

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

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


21765 / 76734 ←次へ | 前へ→

【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

2 hits

【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 お礼

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