Excel VBA質問箱 IV

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

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


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

27694 / 76732

←次へ　｜　前へ→


	【54355】Re:bitmapで計算結果を出力

Yuki - 08/3/10(月) 10:04 -


	引用なし

	パスワード

▼けにちさん：
>質問：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

0 hits

▼

【54343】bitmapで計算結果を出力 けにち 08/3/9(日) 3:24