ビットマップ画像の色の取得

ビットマップ画像の色の取得2012.09.27　　　［更新日］2024.12.04

Win32APIを用い、ビットマップ画像の色を取得するサンプルコードとメモです。

ポイント

　・画像の高さ・幅の取得
　・Application.PathSeparatorプロパティ
　・WinAPI

【お薦め】マクロ・プロシージャを管理する無料のツール！
　Excelマクロ管理ツール

サンプルコード

BMP画像の色を取得し、セル背景色にそれらを設定していくサンプルコード（Excel2010以降用）。
（セル背景色に設定する色が多すぎる場合エラーになることがあります）

※ 事前に高さ・幅とも 300 ピクセル以内のBMP画像を準備しておく
※ 関連ソフト：「画像とセル背景色の相互変換」アドイン

' ***（宣言セクションに記述）***
'-------------------------------
' Win32API
'-------------------------------
'《指定したデバイスと互換性のあるメモリ デバイス コンテキストを作成》
' 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
                                        
'《指定した座標にあるピクセルのRGBの色値を取得》
' https://learn.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-getpixel
Declare PtrSafe Function GetPixel Lib "gdi32" ( _
                                        ByVal hDC As LongPtr, _
                                        ByVal x As Long, _
                                        ByVal y As Long) As Long

'《アイコン、カーソル、アニメーションカーソル、またはビットマップを読み込む》
' https://learn.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-loadimagea
Declare PtrSafe Function LoadImage Lib "user32" Alias "LoadImageA" ( _
                                        ByVal hinst As LongPtr, _
                                        ByVal lpszName As String, _
                                        ByVal uType As Long, _
                                        ByVal cxDesired As Long, _
                                        ByVal cyDesired As Long, _
                                        ByVal fuLoad As Long) As LongPtr
'-------------------------------
' 定数
'-------------------------------
' LoadImageA関数のパラメーター
' 名前で指定されたファイルからスタンドアロン イメージを読み込む
Const LR_LOADFROMFILE = &H10
' ***（ここまで）***

'-----------------------------------------------------------------
' BMPファイルの色を取得しシートの背景色に設定
'-----------------------------------------------------------------
'［作成日］2012.09.27　［更新日］2024.12.04
' https://excel.syogyoumujou.com/memorandum/get_bmp.html
'-----------------------------------------------------------------
Sub BMPファイルの色を取得しシートの背景色に設定する()

On Error GoTo LBL_ERROR

    '---------------------------------------
    ' ファイルを選択
    '---------------------------------------
    Dim varFilePath As Variant
    Dim strFilePath As String
    '《ファイル選択ダイアログボックス》
    ' ・ 引数1：ファイルフィルター
    ' ・ 引数2：ファイルインデックス（既定で表示するフィルター文字列の指定）
    ' ・ 引数3：ダイアログボックスタイトル
    ' ・ 引数4：ボタンテキスト（Macintosh用）
    ' ・ 引数5：複数選択の設定（True：複数選択可　False：複数選択不可）
    varFilePath = Application.GetOpenFilename("ビットマップ,*.bmp", _
                                              1, _
                                              "BMPファイルを選択してください　※ファイルの幅・高さ共に300ピクセル以内", _
                                              , _
                                              False)
                                              
    '［キャンセル］ボタンをクリックした場合は抜ける
    If VarType(varFilePath) = vbBoolean Then Exit Sub
    
    ' ファイルパスを文字列型変数に代入
    If IsArray(varFilePath) Then
        strFilePath = varFilePath(LBound(varFilePath))
    Else
        strFilePath = varFilePath
    End If

    '---------------------------------------
    ' 画像の色取得
    '---------------------------------------
    Dim varArray2dColor As Variant
    '《画像の各ピクセルの色を取得し2次元配列に設定》
    ' ・ 引数1：画像のファイルパス
    varArray2dColor = getArray2dPixcelColor(strFilePath)
    If Not IsArray(varArray2dColor) Then
        MsgBox "画像の幅・高さが処理対応上限を超えています" & vbLf & _
               "最大処理対応ピクセル：300×300", vbExclamation
        Exit Sub
    End If

    '---------------------------------------
    ' シートに色を設定
    '---------------------------------------
    Application.ScreenUpdating = False
    
    ' 新規ブックを追加しシートをセット
    Dim shtNew As Worksheet
    Set shtNew = Workbooks.Add.Worksheets(1)
    ' シートの列幅・行高さ調整
    shtNew.Cells.ColumnWidth = 0.23
    shtNew.Cells.RowHeight = 2.25

    Dim i As Long
    Dim j As Long
    For i = 1 To UBound(varArray2dColor, 1)
        For j = 1 To UBound(varArray2dColor, 2)
            shtNew.Cells(i, j).Interior.Color = varArray2dColor(i, j)
        Next
    Next
    
    Application.ScreenUpdating = True

On Error GoTo 0

    Exit Sub
    
'---------------------------------------
' エラー処理
'---------------------------------------
LBL_ERROR:
    MsgBox "エラー番号：" & Err.Number & vbLf & _
           "エラー説明：" & Err.Description, vbExclamation
End Sub

'-----------------------------------------------------------------
' 画像の各ピクセルの色を取得し2次元配列に設定
'-----------------------------------------------------------------
'［引数］
'   FilePath：画像のファイルパス
'［戻り値］
'   成功：各ピクセルの色値が設定された2次元配列
'   失敗：Empty
'［作成日］2012.09.27　［更新日］2024.12.04
' https://excel.syogyoumujou.com/memorandum/get_bmp.html
'-----------------------------------------------------------------
Function getArray2dPixcelColor(ByVal FilePath As String) As Variant

    '---------------------------------------
    ' 画像の幅と高さを取得
    '---------------------------------------
    Dim objImage  As Object
    Dim lngWidth  As Long
    Dim lngHeight As Long
    '《イメージ読込》
    ' 引数1：画像のファイルパス
    Set objImage = LoadPicture(FilePath)
    lngWidth = CLng(objImage.Width * 0.0378)
    lngHeight = CLng(objImage.Height * 0.0378)
    Set objImage = Nothing
    
    ' 想定範囲を超える画像の場合は処理を抜ける
    If 300 < lngHeight Or 300 < lngWidth Then Exit Function
    
    '---------------------------------------
    ' 2次元配列生成
    '---------------------------------------
    Dim varArray2d() As Variant
    ReDim varArray2d(1 To lngHeight, 1 To lngWidth)

    '---------------------------------------
    ' 画像の色取得
    '---------------------------------------
    Dim i         As Long
    Dim j         As Long
    Dim hdlDC     As LongPtr
    Dim hdlbmp    As LongPtr
    Dim hdlOldBmp As LongPtr
    '《メモリデバイスコンテキスト作成》
    ' ・ 引数1：既存の DC へのハンドル
    '           ※ 0 の場合は現在の画面と互換性のあるメモリ DC を作成する
    hdlDC = CreateCompatibleDC(0)
    
    '《ビットマップ読込》
    ' ・ 引数1：読み込まれるイメージを含む DLL 等へのハンドル
    ' ・ 引数2：ファイルフルパス ※ 第6引数が LR_LOADFROMFILE の場合
    ' ・ 引数3：読み込むイメージの種類
    ' ・ 引数4：アイコンまたはカーソルの幅
    ' ・ 引数5：アイコンまたはカーソルの高さ
    ' ・ 引数6：パラメーター
    hdlbmp = LoadImage(0, FilePath, 0, 0, 0, LR_LOADFROMFILE)

    '《オブジェクト選択》
    ' ・ 引数1：対象 DC へのハンドル
    ' ・ 引数2：選択するオブジェクトへのハンドル
    ' ※ 戻り値は置き換えられるオブジェクトへのハンドル
    hdlOldBmp = SelectObject(hdlDC, hdlbmp)
    
    ' 各ピクセルの色を取得
    For i = 1 To lngHeight
        For j = 1 To lngWidth
            '《指定座標ピクセルの色値取得》
            ' ・ 引数1：デバイスコンテキストへのハンドル
            ' ・ 引数2：ピクセルの x 座標
            ' ・ 引数3：ピクセルの y 座標
            varArray2d(i, j) = GetPixel(hdlDC, j - 1, i - 1)
        Next
    Next
    
    '《オブジェクト選択》
    ' 選択オブジェクトを戻す
    hdlbmp = SelectObject(hdlDC, hdlOldBmp)
    
    '《デバイス コンテキスト削除》
    ' 引数1：デバイスコンテキストへのハンドル
    Call DeleteDC(hdlDC)
    
    '《オブジェクト削除》
    ' 引数1：デバイスコンテキストへのハンドル
    Call DeleteObject(hdlbmp)

    '---------------------------------------
    ' 戻り値設定
    '---------------------------------------
    getArray2dPixcelColor = varArray2d
End Function

VBAコードをカラーで印刷・Web掲載するためのツールはこちら

メモ

画像の大きさ（高さと幅）の取得】

LoadPicture関数を用い、Object変数に画像を読み込み、その高さと幅を取得。
LoadPicture関数は、Picture型のオブジェクトを返す。
PictureオブジェクトのWidth、Heightプロパティから、画像の高さと幅を求めるが、それらの単位はピクセルではない。
単位をピクセルに変換するため、0.0378を掛け、さらにCLng関数で丸める。

LoadPicture関数

フォームやイメージコントロール等のPictureプロパティや、Iconプロパティに画像を表示する。

構文：LoadPicture([picturefilename])

[picturefilename]
画像のパス・ファイル名を指定。引数を省略、又は「""」空の文字列にすると、既に設定されている画像が消去される。

Application.PathSeparatorプロパティ

[ 参照 ]

CreateCompatibleDC / DeleteDC関数 (Win32API)

［参考］Microsoft Learn Challenge CreateCompatibleDC 関数
　　　　Microsoft Learn Challenge DeleteDC 関数

LoadImage / SelectObject / DeleteObject関数 (Win32API)

［参考］Microsoft Learn Challenge LoadImageA 関数
　　　　Microsoft Learn Challenge SelectObject 関数
　　　　Microsoft Learn Challenge DeleteObject 関数

トップ　>　備忘録　>　ビットマップ画像の色の取得