ビットマップ画像の作成2012.11.25 [更新日]2024.12.07
Win32APIを用い、ビットマップ画像を作成するサンプルコードとメモです。
Excelマクロ管理ツール
サンプルコード
選択しているセルの背景色を、ビットマップ画像に変換するサンプルコード。
セルの高さや幅に関係なく、1セルは縦横1ピクセルのBMPに変換される。
※対応するセル範囲の大きさは320×320セル
※次のコードを利用したソフト:「画像とセル背景色の相互変換」アドイン
' ***(宣言セクションに記述)*** '------------------------------- ' Win32API '------------------------------- '《アプリケーションが直接書き込むことができる DIB を作成》 ' https://learn.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-createdibsection Declare PtrSafe Function CreateDIBSection Lib "gdi32" ( _ ByVal hDC As LongPtr, _ ByRef pbmi As BITMAPINFO, _ ByVal uUsage As Long, _ ByVal ppvBits As LongPtr, _ ByVal hSection As LongPtr, _ ByVal dwOffset As Long) As LongPtr '《指定した互換性のあるビットマップのビットを取得し指定した形式で DIB としてバッファーにコピー》 ' https://learn.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-getdibits Declare PtrSafe Function GetDIBits Lib "gdi32" ( _ ByVal hDC As LongPtr, _ ByVal hBmp As LongPtr, _ ByVal uStartScan As Long, _ ByVal cScanLines As Long, _ ByRef lpvBits As Any, _ ByRef lpBmi As BITMAPINFO, _ ByVal uUsage As Long) As Long '《指定したデバイスと互換性のあるメモリ デバイス コンテキストを作成》 ' https://learn.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-createcompatibledc Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" ( _ ByVal hDC As LongPtr) As LongPtr '《指定したデバイス コンテキストを削除》 ' https://learn.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-deletedc Declare PtrSafe Function DeleteDC Lib "gdi32" ( _ ByVal hDC As LongPtr) As Long '《指定したオブジェクトを削除》 ' https://learn.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-deleteobject Declare PtrSafe Function DeleteObject Lib "gdi32" ( _ ByVal hObject As LongPtr) As Long '《指定したデバイス コンテキストにオブジェクトを選択》 ' https://learn.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-selectobject Declare PtrSafe Function SelectObject Lib "gdi32" ( _ ByVal hDC As LongPtr, _ ByVal hObject As LongPtr) As LongPtr '《指定した座標のピクセルに指定した色に設定》 ' https://learn.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-setpixel Declare PtrSafe Function SetPixel Lib "gdi32" ( _ ByVal hDC As LongPtr, _ ByVal x As Long, _ ByVal y As Long, _ ByVal crColor As Long) As Long '《指定した四角形を指定したデバイス コンテキストに描画》 ' https://learn.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-patblt 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 '------------------------------- ' 構造体 '------------------------------- ' デバイスに依存しないビットマップ (DIB) の寸法と色の形式に関する情報 ' https://learn.microsoft.com/ja-jp/windows/win32/api/wingdi/ns-wingdi-bitmapinfoheader Type BITMAPINFOHEADER biSize As Long ' 構造体に必要なバイト数 biWidth As Long ' ビットマップの幅をピクセル単位で指定 biHeight As Long ' ビットマップの高さをピクセル単位で指定 biPlanes As Integer ' ターゲット デバイスの平面の数を指定 この値は 1 に設定する biBitCount As Integer ' ピクセルあたりのビット数 (bpp) を指定 biCompression As Long ' 非圧縮 RGB 形式の場合 BI_RGB または BI_BITFIELDS を使用できる biSizeImage As Long ' イメージのサイズをバイト単位で指定 非圧縮 RGB ビットマップの場合は 0 に設定 biXPelsPerMeter As Long ' ビットマップのターゲット デバイスの水平方向の解像度をメートルあたりのピクセル単位で指定 biYPelsPerMeter As Long ' ビットマップのターゲット デバイスの垂直方向の解像度をメートルあたりのピクセル単位で指定 biClrUsed As Long ' ビットマップで実際に使用されるカラー テーブル内のカラー インデックスの数を指定 biClrImportant As Long ' ビットマップを表示するために重要と見なされるカラー インデックスの数を指定 0 の場合すべての色が重要 End Type ' 赤、緑、青の相対的な強度で構成される色を表す ' https://learn.microsoft.com/ja-jp/windows/win32/api/wingdi/ns-wingdi-rgbquad Type RGBQUAD rgbBlue As Byte ' 青の強度 rgbGreen As Byte ' 緑の強度 rgbRed As Byte ' 赤の強度 rgbReserved As Byte ' (予約:0) End Type ' ※ CreateDIBSection関数 / GetDIBits関数 で使用するポインター ' DIB のディメンションと色情報を定義 ' https://learn.microsoft.com/ja-jp/windows/win32/api/wingdi/ns-wingdi-bitmapinfo Type BITMAPINFO bmiHeader As BITMAPINFOHEADER ' 色書式のディメンションに関する情報を含む BITMAPINFOHEADER 構造体 bmiColors As RGBQUAD ' カラー テーブルを構成する配列の要素 End Type ' ビットマップ データを受け取るバッファーへのポインター(GetDIBits関数 で使用) ' DIB を含むファイルの種類、サイズ、およびレイアウトに関する情報が含まれている ' https://learn.microsoft.com/ja-jp/windows/win32/api/wingdi/ns-wingdi-bitmapfileheader Type BITMAPFILEHEADER bfType As String * 2 ' ファイルの種類 bfSize As Long ' ビットマップ ファイルのサイズ (バイト単位) bfReserved1 As Integer ' (予約:0) bfReserved2 As Integer ' (予約:0) bfOffBits As Long ' BITMAPFILEHEADER 構造体の先頭からビットマップ ビットまでのオフセット (バイト単位) End Type '------------------------------- ' 定数 '------------------------------- ' ※ PatBlt関数 で使用 Const WHITENESS = &HFF0062 ' 白で塗りつぶす ' ※ CreateDIBSection関数 / GetDIBits 関数 で使用 Const DIB_RGB_COLORS = 0 ' BITMAPINFO 構造体に リテラル RGB 値の配列が含まれている ' ***(ここまで)***
'----------------------------------------------------------------- ' 選択セル範囲の背景色をBMPファイルとして出力 '----------------------------------------------------------------- '[作成日]2012.11.25 [更新日]2024.12.07 ' https://excel.syogyoumujou.com/memorandum/make_bmp.html '----------------------------------------------------------------- Sub 選択セル範囲の背景色をBMPファイルとして出力() On Error GoTo LBL_ERROR '--------------------------------------- ' 選択セル背景色取得 '--------------------------------------- ' セル選択確認 If TypeName(Application.Selection) <> "Range" Then MsgBox "セル範囲を選択してからマクロを実行してください", vbInformation Exit Sub End If ' オブジェクト変数に選択セル範囲を設定 Dim rngTarget As Range Set rngTarget = Application.Selection ' 出力対応範囲確認 If 320 < rngTarget.Rows.Count Or 320 < rngTarget.Columns.Count Then MsgBox "選択範囲が広すぎます" & vbLf & "対応範囲:320×320", vbInformation Exit Sub End If Dim varArray2dColor As Variant '《対象セル範囲の各セル背景色を2次元配列で取得》 ' ・ 引数1:対象セル範囲 varArray2dColor = getArray2dInteriorColor(rngTarget) '--------------------------------------- ' ダイアログボックス表示 '--------------------------------------- Dim varFileName As Variant '《名前をつけて保存ダイアログボックス》 ' ・ 引数1:初期ファイル名 ' ・ 引数2:ファイルフィルター ' ・ 引数3:ファイルインデックス(既定で表示するフィルター文字列の指定) ' ・ 引数4:ダイアログボックスタイトル(省略した場合は"名前を付けて保存") ' ・ 引数5:ボタンテキスト(Macintosh用のため使用しない) varFileName = Application.GetSaveAsFilename(Format$(Now(), "yyyymmdd_hhnnss"), "BMP,*.bmp") '[キャンセル]ボタンをクリックした場合は抜ける If VarType(varFileName) = vbBoolean Then Exit Sub '--------------------------------------- ' ビットマップ出力 '--------------------------------------- '《2次元配列の色値を基にビットマップを出力》 ' ・ 引数1:出力ファイルパス ' ・ 引数2:色値が設定された2次元配列 Call outputBitmapFromArray2dColor(varFileName, varArray2dColor) '------------------------------- ' 出力ファイルを開く '------------------------------- CreateObject("WScript.Shell").Run ("""" & varFileName & """") On Error GoTo 0 Exit Sub '--------------------------------------- ' エラー処理 '--------------------------------------- LBL_ERROR: MsgBox "エラー番号:" & Err.Number & vbLf & _ "エラー説明:" & Err.Description, vbExclamation End Sub
'----------------------------------------------------------------- ' 対象セル範囲の各セル背景色を2次元配列で取得 '----------------------------------------------------------------- '[引数] ' rngTarget:対象セル範囲 '[戻り値] ' 成功:各セルの背景色の色値が設定された2次元配列 ' 失敗:Empty '[作成日]2012.11.25 [更新日]2024.12.07 ' https://excel.syogyoumujou.com/memorandum/make_bmp.html '----------------------------------------------------------------- Function getArray2dInteriorColor(ByVal rngTarget As Range) As Variant ReDim varArray2d(1 To rngTarget.Rows.Count, 1 To rngTarget.Columns.Count) As Variant Dim i As Long Dim j As Long For i = 1 To UBound(varArray2d, 1) For j = 1 To UBound(varArray2d, 2) varArray2d(i, j) = rngTarget.Cells(i, j).Interior.Color Next Next getArray2dInteriorColor = varArray2d End Function
'----------------------------------------------------------------- ' 2次元配列の色値を基にビットマップを出力 '----------------------------------------------------------------- '[引数] ' FilePath:出力するファイルのフルパス ' Array2d :色値が設定された2次元配列 '[戻り値] ' なし '[作成日]2012.11.25 [更新日]2024.12.07 ' https://excel.syogyoumujou.com/memorandum/make_bmp.html '----------------------------------------------------------------- Sub outputBitmapFromArray2dColor(ByVal FilePath As String, _ ByVal Array2d As Variant) '--------------------------------------- ' 2次元配列の行列数取得 '--------------------------------------- Dim lngRowsCount As Long Dim lngColumnsCount As Long lngRowsCount = UBound(Array2d, 1) - LBound(Array2d, 1) + 1 lngColumnsCount = UBound(Array2d, 2) - LBound(Array2d, 2) + 1 '--------------------------------------- ' デバイスコンテキスト・ビットマップ生成 '--------------------------------------- Dim hdlDC As LongPtr '《メモリデバイスコンテキスト作成》 ' ・ 引数1:既存の DC へのハンドル ' ※ 0 の場合は現在の画面と互換性のあるメモリ DC を作成する hdlDC = CreateCompatibleDC(0) ' DIB のディメンションと色情報を設定 Dim typBitmapInfo As BITMAPINFO With typBitmapInfo.bmiHeader .biSize = 40 ' 構造体に必要なバイト数 .biWidth = lngColumnsCount ' Bitmapの幅 .biHeight = lngRowsCount ' Bitmapの高 .biPlanes = 1 ' デバイスの平面の数 1 を指定 .biBitCount = 24 ' ピクセルあたりのビット数 (bpp) End With Dim hdlBmp As LongPtr '《アプリケーションが直接書き込むことができる DIB を作成》 ' ・ 引数1:デバイスコンテキストを識別するハンドル ' ・ 引数2:DIB の様々な属性を指定する BITMAPINFO 構造体へのポインター ' ・ 引数3:引数2の構造体の bmiColor 配列メンバーに含まれるデータの型 ' ・ 引数4:DIB ビット値の場所へのポインターを受け取る変数へのポインター ' ・ 引数5:DIB の作成に関数が使用するファイル マッピング オブジェクトへのハンドル ' ※ 0 の場合システムは DIB にメモリを割り当てる(この場合引数6は無視される) ' ・ 引数6:引数5 によって参照されるファイル マッピング オブジェクトの先頭からのオフセット hdlBmp = CreateDIBSection(hdlDC, typBitmapInfo, DIB_RGB_COLORS, 0, 0, 0) Dim hdlOldBmp As LongPtr '《オブジェクト選択》 ' ・ 引数1:対象 DC へのハンドル ' ・ 引数2:選択するオブジェクトへのハンドル ' ※ 戻り値は置き換えられるオブジェクトへのハンドル hdlOldBmp = SelectObject(hdlDC, hdlBmp) '--------------------------------------- ' ビットマップに関連づけられたDCに描画 '--------------------------------------- ' 《指定した四角形を指定したデバイス コンテキストに描画》 ' ・ 引数1:デバイス コンテキストへのハンドル ' ・ 引数2:塗りつぶす四角形の左上隅の x 座標 ' ・ 引数3:塗りつぶす四角形の左上隅の y 座標 ' ・ 引数4:四角形の幅 ' ・ 引数5:四角形の高さ ' ・ 引数6:ラスター演算コード Call PatBlt(hdlDC, 0, 0, lngColumnsCount, lngRowsCount, WHITENESS) ' デバイスコンテキストを白で塗りつぶす ' 2次元配列の色値をデバイスコンテキストに設定 Dim i As Long Dim j As Long For i = LBound(Array2d, 1) To UBound(Array2d, 1) For j = LBound(Array2d, 2) To UBound(Array2d, 2) '《指定した座標のピクセルに指定した色に設定》 ' ・ 引数1:デバイス コンテキストへのハンドル ' ・ 引数2:設定するポイントの x 座標 ' ・ 引数3:設定するポイントの y 座標 ' ・ 引数4:ポイントの描画に使用する色値 Call SetPixel(hdlDC, j - 1, i - 1, Array2d(i, j)) Next Next '--------------------------------------- ' 出力準備 '--------------------------------------- ' バイト数算出 Dim lngByteCount As Long lngByteCount = Int((lngColumnsCount * 24 + 31) \ 32) * 4 * lngRowsCount ' bytBmpBits 設定 Dim bytBmpBits() As Byte ReDim bytBmpBits(lngByteCount - 1) '《指定した互換性のあるビットマップのビットを取得し指定した形式で DIB としてバッファーにコピー》 ' ・ 引数1:デバイス コンテキストへのハンドル ' ・ 引数2:互換性のあるビットマップへのハンドル ' ・ 引数3:取得する最初のスキャン行 ' ・ 引数4:取得するスキャン行の数 ' ・ 引数5:ビットマップ データを受け取るバッファーへのポインター ' ・ 引数6:DIB データの目的の形式を指定する BITMAPINFO 構造体へのポインター ' ・ 引数7:BITMAPINFO 構造体の bmiColors メンバーの形式 Call GetDIBits(hdlDC, hdlBmp, 0, lngRowsCount, bytBmpBits(0), typBitmapInfo, DIB_RGB_COLORS) ' ビットマップのヘッダー情報設定 Dim typBitmapFileHeader As BITMAPFILEHEADER With typBitmapFileHeader ' ファイルの種類 .bfType = "BM" ' ビットマップ ファイルのサイズ (バイト単位) .bfSize = Len(typBitmapFileHeader) + Len(typBitmapInfo) + UBound(bytBmpBits) + 1 ' BITMAPFILEHEADER 構造体の先頭からビットマップ ビットまでのオフセット (バイト単位) .bfOffBits = Len(typBitmapFileHeader) + Len(typBitmapInfo) End With '--------------------------------------- ' ビットマップ出力 '--------------------------------------- Dim lngFreeFileNumber As Long lngFreeFileNumber = FreeFile() Open FilePath For Binary As #lngFreeFileNumber Put #lngFreeFileNumber, , typBitmapFileHeader ' ビットマップファイルヘッダ Put #lngFreeFileNumber, , typBitmapInfo ' ビットマップ情報 Put #lngFreeFileNumber, , bytBmpBits ' 画像データ Close #lngFreeFileNumber '--------------------------------------- ' 終了処理 '--------------------------------------- '《オブジェクト選択》 ' 選択オブジェクトを戻す hdlBmp = SelectObject(hdlDC, hdlOldBmp) '《デバイス コンテキスト削除》 ' 引数1:デバイスコンテキストへのハンドル Call DeleteDC(hdlDC) '《オブジェクト削除》 ' 引数1:デバイスコンテキストへのハンドル Call DeleteObject(hdlBmp) End Sub
メモ
TypeName関数
変数に関する情報を提供する文字列型 (String) の文字列を返す。
構文:TypeName(varname)
[varname]
任意のバリアント型 (Variant) の変数必ず指定。
【補足】
TypeName 関数によって次のいずれかの文字列が返る。
varnameが配列の場合、上記の該当する文字列に、空のかっこ "()" がつく。
例えば、varnameが整数の配列では "Integer()" を返す。
FreeFile関数
使用可能なファイル番号を整数型 (Integer) の値で返す。
既に使われているファイル番号を重複して使うのを防ぐことができる。
構文:FreeFile[(rangenumber)]
[rangenumber]
省略可。ファイル番号の範囲をバリアント型 (Variant) で指定。
指定した範囲から次に使用可能なファイル番号を返す。
Application.GetSaveAsFilenameメソッド
[ 参照 ]
CreateCompatibleDC / DeleteDC 関数 (Win32API)
[参考]Microsoft Learn Challenge CreateCompatibleDC 関数
Microsoft Learn Challenge DeleteDC 関数
SelectObject / DeleteObject 関数 (Win32API)
[参考]Microsoft Learn Challenge LoadImageA 関数
Microsoft Learn Challenge SelectObject 関数
Microsoft Learn Challenge DeleteObject 関数
CreateDIBSection / GetDIBits 関数(Win32API)
[参考]Microsoft Learn Challenge CreateDIBSection 関数
Microsoft Learn Challenge GetDIBits 関数
Patblt / SetPixel 関数(Win32API)
[参考]Microsoft Learn Challenge Patblt 関数
Microsoft Learn Challenge SetPixel 関数