|
▼けにち さん:
>質問:Excel VBAで画像を構成してBitmap形式などでファイルに書き出すことはできるでしょうか?
>
>ちょっと調べるとSavePictureというものは見つかったのですが、ボタンなどの画像を保存する方法しかわかりませんでした。
試してみて下さい。
Option Explicit
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 Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Sub TEST() ' 此処を実行
Dim strFileName As String
strFileName = "D:\hogehogeBitMap.bmp"
ActiveSheet.Range("範囲").CopyPicture xlScreen, xlBitmap
SavePicture GetBitMap(), strFileName
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
|
|