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

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

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

ポイント

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


サンプルコード

BMP画像の色を取得し、セル背景色にそれらを設定していくサンプルコード。
※Excel2007以降用。Excel2003でも動作するが、色が正確に反映されない。
※下記のコードをVBEに貼り付ると、一部赤く表示される場合があるが、エラーではない。
※320×240ピクセル以内のBMP画像をデスクトップに準備し、「sample.bmp」と名前を付けた後実行
※次のコードを利用したソフト:「画像とセル背景色の相互変換」アドイン


'///宣言セクションに記述///
#If VBA7 And Win64 Then
    '64ビット
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" ( _
        ByVal hDC As Long) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" ( _
        ByVal hDC As Long) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" ( _
        ByVal hObject As Long) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" ( _
        ByVal hDC As Long, _
        ByVal hObject As Long) As Long
    Private Declare PtrSafe Function GetPixel Lib "gdi32" ( _
        ByVal hDC As Long, _
        ByVal x As Long, _
        ByVal y As Long) As Long
    Private Declare PtrSafe Function LoadImage Lib "user32" Alias "LoadImageA" ( _
        ByVal hinst As Long, _
        ByVal lpszName As String, _
        ByVal uType As Long, _
        ByVal cxDesired As Long, _
        ByVal cyDesired As Long, _
        ByVal fuLoad As Long) As Long
#Else
    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" ( _
        ByVal hObject As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" ( _
        ByVal hDC As Long, _
        ByVal hgdiobj As Long) As Long
    Private Declare Function GetPixel Lib "gdi32" ( _
        ByVal hDC As Long, _
        ByVal x As Long, _
        ByVal y As Long) As Long
    Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" ( _
        ByVal hinst As Long, _
        ByVal lpszName As String, _
        ByVal uType As Long, _
        ByVal cxDesired As Long, _
        ByVal cyDesired As Long, _
        ByVal fuLoad As Long) As Long
#End If

Private Const LR_LOADFROMFILE = &H10

Type FileWH
    w As Long
    h As Long
    ERROR As String
End Type
'///ここまで///
'-------------------------------------------------------------------------------------------------------

Sub Get_BMP_Sample()
    Dim strPS As String
    Dim strFP As String
    Dim typFWH As FileWH
    strPS = Application.PathSeparator
    strFP = DeskTop_Path() & strPS & "sample.bmp"
    typFWH = Check_FileSize(strFP)
    With typFWH
        If .ERROR <> "" Then
            MsgBox .ERROR, vbExclamation + vbOKOnly: Exit Sub
        End If
        Call Load_BMP_Image(strFP, .w, .h)
    End With
End Sub
'-------------------------------------------------------------------------------------------------------

Private Function DeskTop_Path() As String
    Dim objWShell As Object 'WScript.Shell
    Set objWShell = CreateObject("WScript.Shell")
    'デスクトップパス
    DeskTop_Path = objWShell.SpecialFolders("Desktop")
End Function
'-------------------------------------------------------------------------------------------------------

Private Function Check_FileSize(ByVal FP As String) As FileWH
    Dim objImage As Object
    On Error GoTo ERROR
        Set objImage = LoadPicture(FP)
        With Check_FileSize
            .w = CLng(objImage.Width * 0.0378)
            .h = CLng(objImage.Height * 0.0378)
            If .w < 321 And .h < 321 Then Exit Function
            .ERROR = "処理対応上限を超えています" & vbCrLf _
                            & "最大処理対応ピクセル:240×320"
        End With
    On Error GoTo 0
Exit Function
ERROR:
    Check_FileSize.ERROR = "ファイルが存在しない、またはファイル形式が対象外、" _
                    & vbCrLf & "又はフォルダへのアクセスが制限されています。"
End Function
'-------------------------------------------------------------------------------------------------------

Private Sub Load_BMP_Image(file As String, w As Long, h As Long)
    Dim intI As Long
    Dim intII As Long
    Dim oldBmp As Long
    Dim DC, bmp
    DC = CreateCompatibleDC(0) 'スクリーンDCに関連あるDCを作成
    bmp = LoadImage(0, file, 0, 0, 0, LR_LOADFROMFILE) 'BMP読込
    oldBmp = SelectObject(DC, bmp) '作成したDCにbmpを関連付ける
    With Application
        .ScreenUpdating = False
        With .ActiveWorkbook.ActiveSheet
            With .Cells
                .Clear
                .ColumnWidth = 0.23
                .RowHeight = 2.25
            End With
            If .Columns.Count < w Then w = .Columns.Count
            For intI = 1 To h
                For intII = 1 To w
                    .Cells(intI, intII).Interior.Color = GetPixel(DC, intII - 1, intI - 1)
                Next
            Next
        End With
        .ScreenUpdating = True
    End With
    bmp = SelectObject(DC, oldBmp)
    Call DeleteDC(DC)
    Call DeleteObject(bmp)
End Sub

メモ

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

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

 構文:LoadPicture([picturefilename])

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

◆Application.PathSeparatorプロパティ
 [ 参照 ]

◆CreateCompatibleDC/DeleteDC関数(Win32API)
 [ 参照 ]

◆LoadImage/SelectObject/DeleteObject関数(Win32API)
 [ 参照 ]

◆GetPixel関数(Win32API)
 後日記載

Excel Tips for Teachers

Copyright (C) 2009- 坂江 保 All Rights Reserved.