Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

27650 / 76732

←次へ　｜　前へ→


	【54399】Re:Formに描画(API LineTo など）した絵をBitMapで保存できますか？

VBWASURETA - 08/3/11(火) 17:45 -


	引用なし

	パスワード

▼みそじのおじさんさん：

先ほど書いたハードコピーのサンプルです。
ハードコピーからBitmap形式保存はYukiさんソースから
拝借しました。
後、Sendkeyは使いたくなかったのでAPIにしました。
色々と不具合が多いので。

Private Type GUID
　　Data1 As Long
　　Data2 As Integer
　　Data3 As Integer
　　Data4(0 To 7) As Byte
End Type

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 GUID, ByVal fPictureOwnsHandle As Long, _
　　　　　　　　 IPic As IPictureDisp) As Long

Private Declare Function timeGetTime Lib "winmm.dll" () As Long

'****************************************************
'キーボードイベント
Private Declare Sub keybd_event Lib "user32.dll" _
　 (ByVal bVk As Byte, ByVal bScan As Byte, _
　　ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const KEYEVENTF_KEYUP = &H2
Private Const KEYEVENTF_EXTENDEDKEY = &H1
Private Const VK_ALT = &H12
Private Const VK_SNAPSHOT = &H2C

Private Declare Function MapVirtualKey Lib "user32" _
　　Alias "MapVirtualKeyA" (ByVal wCode As Long, _
　　ByVal wMapType As Long) As Long
'****************************************************

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

Private Sub sSetSendKeys(bVk1 As Long, _
　　　　　　　　Optional bVk2 As Long = 0, Optional bVk3 As Long = 0)
　　
　　If bVk2 = 0& And bVk3 = 0& Then
　　　　Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
　　　　　　　　　　　　KEYEVENTF_EXTENDEDKEY Or 0, 0)
　　　　Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
　　　　　　　　　　　　KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
　　ElseIf bVk3 = 0& Then
　　　　Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
　　　　　　　　　　　　KEYEVENTF_EXTENDEDKEY Or 0, 0)
　　　　Call keybd_event(CByte(bVk2), MapVirtualKey(CByte(bVk2), 0), _
　　　　　　　　　　　　KEYEVENTF_EXTENDEDKEY Or 0, 0)
　　　　Call keybd_event(CByte(bVk2), MapVirtualKey(CByte(bVk2), 0), _
　　　　　　　　　　　　KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
　　　　Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
　　　　　　　　　　　　KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
　　ElseIf (bVk1 <> 0&) And (bVk2 <> 0&) And (bVk3 <> 0&) Then
　　　　Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
　　　　　　　　　　　　KEYEVENTF_EXTENDEDKEY Or 0, 0)
　　　　Call keybd_event(CByte(bVk2), MapVirtualKey(CByte(bVk2), 0), _
　　　　　　　　　　　　KEYEVENTF_EXTENDEDKEY Or 0, 0)
　　　　Call keybd_event(CByte(bVk2), MapVirtualKey(CByte(bVk2), 0), _
　　　　　　　　　　　　KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
　　　　Call keybd_event(CByte(bVk3), MapVirtualKey(CByte(bVk3), 0), _
　　　　　　　　　　　　KEYEVENTF_EXTENDEDKEY Or 0, 0)
　　　　Call keybd_event(CByte(bVk3), MapVirtualKey(CByte(bVk3), 0), _
　　　　　　　　　　　　KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
　　　　Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
　　　　　　　　　　　　KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
　　End If
　　StopTime (50)
End Sub

Private Sub StopTime(st As Long)
　　Dim lngSt As Long
　　lngSt = timeGetTime
　　Do While timeGetTime - lngSt < st
　　　　DoEvents
　　Loop
End Sub

Function GetBitMap() As IPictureDisp
　Dim iid As GUID
　Dim Pic As PicBmp
　Dim ObjPic As IPictureDisp
　Dim hBitmap As Long
　Dim CopyBitmap As Long

　With iid
　　.Data1 = &H20400
　　.Data4(0) = &HC0
　　.Data4(7) = &H46
　End With

　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

　OleCreatePictureIndirect Pic, iid, 1, ObjPic
　Set GetBitMap = ObjPic
End Function

Function test()
　　Dim setfile As String
　　
　　setfile = "C:\test.bmp"
　　'Alt + PrintScreenキーでのハードコピー取得
　　Call sSetSendKeys(VK_ALT, VK_SNAPSHOT)
　　SavePicture GetBitMap(), setfile
End Function

1 hits

▼

【54392】Formに描画(API LineTo など）した絵をBitMapで保存できますか？ みそじのおじさん 08/3/11(火) 14:51