| |
▼すう さん：
こんにちは。
新しいブックに貼り付けてテストをしてみてください。
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
' シート１の背景設定
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
|
|
Yuki
- 09/2/12(木) 17:13 -
