トップ　>　備忘録　>　ビットマップ画像の作成

' ***（宣言セクションに記述）***
'-------------------------------
' 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