ビットマップ画像の作成2012.11.25
Win32APIを用い、ビットマップ画像を作成するサンプルコードとメモです。
【お薦め】マクロ・プロシージャを管理する無料のツール!
Excelマクロ管理ツール
Excelマクロ管理ツール
サンプルコード
選択しているセルの背景色を、ビットマップ画像に変換するサンプルコード。
セルの高さや幅に関係なく、1セルは縦横1ピクセルのBMPに変換される。
※下記のコードをVBEに貼り付ると、一部赤く表示される場合があるが、エラーではない。
※対応するセル範囲の大きさは320×320セル
※次のコードを利用したソフト:「画像とセル背景色の相互変換」アドイン
'///宣言セクションに記述/// #If VBA7 Then 'Excel2010以上 Private Declare PtrSafe Function PatBlt Lib "gdi32" ( _ ByVal hDC As LongPtr, _ ByVal x As Long, _ ByVal y As Long, _ ByVal w As Long, _ ByVal h As Long, _ ByVal dwRop As Long) As Long Private Declare PtrSafe Function SetPixel Lib "gdi32" ( _ ByVal hDC As LongPtr, _ ByVal x As Long, _ ByVal y As Long, _ ByVal crColor As Long) As Long Private Declare PtrSafe Function CreateDIBSection Lib "gdi32" ( _ ByVal hDC As LongPtr, _ pbmi As BITMAPINFO, _ ByVal iUsage As Long, _ ByVal ppvBits As LongPtr, _ ByVal hSection As LongPtr, _ ByVal dwOffset As Long) As LongPtr Private Declare PtrSafe Function GetDIBits Lib "gdi32" ( _ ByVal hDC As LongPtr, _ ByVal hBmp As LongPtr, _ ByVal uStartScan As Long, _ ByVal cScanLines As Long, _ lpBits As Any, _ lpBI As BITMAPINFO, _ ByVal uUsage As Long) As Long Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" ( _ ByVal hDC As LongPtr) As LongPtr Private Declare PtrSafe Function DeleteDC Lib "gdi32" ( _ ByVal hDC As LongPtr) As Long Private Declare PtrSafe Function DeleteObject Lib "gdi32" ( _ ByVal hObject As LongPtr) As Long Private Declare PtrSafe Function SelectObject Lib "gdi32" ( _ ByVal hDC As LongPtr, _ ByVal hObject As LongPtr) As LongPtr #Else Private Declare Function PatBlt Lib "gdi32" ( _ ByVal hDC As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal w As Long, _ ByVal h As Long, _ ByVal dwRop As Long) As Long Private Declare Function SetPixel Lib "gdi32" ( _ ByVal hDC As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal crColor As Long) As Long Private Declare Function CreateDIBSection Lib "gdi32" ( _ ByVal hDC As Long, _ pbmi As BITMAPINFO, _ ByVal iUsage As Long, _ ByVal ppvBits As Long, _ ByVal hSection As Long, _ ByVal dwOffset As Long) As Long Private Declare Function GetDIBits Lib "gdi32" ( _ ByVal hDC As Long, _ ByVal hBmp As Long, _ ByVal uStartScan As Long, _ ByVal cScanLines As Long, _ lpvBits As Any, _ lpBI As BITMAPINFO, _ ByVal uUsage As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" ( _ ByVal hDC As Long) As Long Private Declare Function DeleteDC Lib "gdi32" ( _ ByVal hDC As Long) As Long Private Declare Function DeleteObject Lib "gdi32.dll" ( _ ByVal hObject As Long) As Long Private Declare Function SelectObject Lib "gdi32.dll" ( _ ByVal hDC As Long, _ ByVal hgdiobj As Long) As Long #End If Private Type BITMAPFILEHEADER bfType As String * 2 bfSize As Long bfReserved1 As Integer bfReserved2 As Integer bfOffBits As Long End Type Private Type BITMAPINFOHEADER biSize As Long biWidth As Long biHeight As Long biPlanes As Integer biBitCount As Integer biCompression As Long biSizeImage As Long biXPelsPerMeter As Long biYPelsPerMeter As Long biClrUsed As Long biClrImportant As Long End Type Private Type BITMAPINFO bmiHeader As BITMAPINFOHEADER 'bmiColors As RGBQUAD End Type Private Const WHITENESS = &HFF0062 '白で塗りつぶす Private Const DIB_RGB_COLORS = 0
'///ここまで/// Sub Conv_Cells_BmpImage() Dim strFilePath As String strFilePath = Application.GetSaveAsFilename(FileFilter:="BMP,*.bmp") If UCase$(strFilePath) = "FALSE" Then Exit Sub Call BMP_Save_Main(strFilePath) End Sub
Sub BMP_Save_Main(ByVal strFN As String) Dim i As Long, ii As Long Dim hDC As Long, hmDC As Long Dim lngSR As Long, lngSC As Long Dim hBmp As Long, hOldBmp As Long Dim lngFNum As Long, lngTRs As Long Dim lngTCs As Long, lngBytC As Long Dim strFileName As String Dim typBmi As BITMAPINFO Dim typBmiFH As BITMAPFILEHEADER Dim bytBmpBits() As Byte If TypeName(Application.Selection) <> "Range" Then Exit Sub With Application.Selection lngTRs = .Rows.Count lngTCs = .Columns.Count lngSR = .Cells(1, 1).Row lngSC = .Cells(1, 1).Column End With If 320 < lngTRs Or 320 < lngTCs Then MsgBox "選択範囲が広すぎます。対応範囲:320×320", vbInformation: Exit Sub End If hmDC = CreateCompatibleDC(0) With typBmi.bmiHeader .biSize = 40 .biWidth = lngTCs '幅 .biHeight = lngTRs '高 .biPlanes = 1 .biBitCount = 24 End With hBmp = CreateDIBSection(hmDC, typBmi, DIB_RGB_COLORS, 0, 0, 0) hOldBmp = SelectObject(hmDC, hBmp) Call PatBlt(hmDC, 0, 0, lngTCs, lngTRs, WHITENESS) With ActiveSheet For i = lngSR To lngSR + lngTRs - 1 For ii = lngSC To lngSC + lngTCs - 1 Call SetPixel(hmDC, ii - lngSC, i - lngSR, .Cells(i, ii).Interior.Color) Next Next End With lngBytC = Int((lngTCs * 24 + 31) \ 32) * 4 * lngTRs ReDim bytBmpBits(lngBytC - 1) Call GetDIBits(hmDC, hBmp, 0, lngTRs, bytBmpBits(0), typBmi, DIB_RGB_COLORS) With typBmiFH .bfType = "BM" .bfSize = Len(typBmiFH) + Len(typBmi) + UBound(bytBmpBits) + 1 .bfOffBits = Len(typBmiFH) + Len(typBmi) End With strFileName = strFN lngFNum = FreeFile() Open strFileName For Binary As #lngFNum Put #lngFNum, , typBmiFH 'ビットマップファイルヘッダ Put #lngFNum, , typBmi 'ビットマップ情報 Put #lngFNum, , bytBmpBits '画像データ Close #lngFNum hBmp = SelectObject(hmDC, hOldBmp) Call DeleteObject(hBmp) Call DeleteDC(hmDC) End Sub
メモ
TypeName関数
変数に関する情報を提供する文字列型 (String) の文字列を返す。
構文:TypeName(varname)
[varname]
任意のバリアント型 (Variant) の変数必ず指定。
【補足】
TypeName 関数によって次のいずれかの文字列が返る。
varnameが配列の場合、上記の該当する文字列に、空のかっこ "()" がつく。
例えば、varnameが整数の配列では "Integer()" を返す。
FreeFile関数
使用可能なファイル番号を整数型 (Integer) の値で返す。
既に使われているファイル番号を重複して使うのを防ぐことができる。
構文:FreeFile[(rangenumber)]
[rangenumber]
省略可。ファイル番号の範囲をバリアント型 (Variant) で指定。
指定した範囲から次に使用可能なファイル番号を返す。
Application.GetSaveAsFilenameメソッド
[ 参照 ]
Open/Closeステートメント
後日記載
GetDC/ReleaseDC/CreateCompatibleDC/DeleteDC関数(Win32API)
[ 参照 ]
SelectObject/DeleteObject(Win32API)
[ 参照 ]
CreateDIBSection/GetDIBits関数関数(Win32API)
[ 参照 ]
Patblt/SetPixel関数(Win32API)
後日記載