| |
▼みそじのおじさん さん：
先ほど書いたハードコピーのサンプルです。
ハードコピーから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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
