オブジェクト関連

オブジェクト関連2012.11.25

Win32APIでBMP画像などを扱うときに、オブジェクトに関連する関数を使用します。ここでは、代表的な関数の宣言と使用例のサンプルコードとメモを記載します。

ポイント

・LoadImage関数（Win32API）
・SelectObject関数（Win32API）
・DeleteObject関数（Win32API）
・CreateDIBSection関数（Win32API）
・GetDIBits関数（Win32API）

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

宣言サンプルコードとメモ

LoadImage関数

アイコン、カーソル、アニメーションカーソル、またはビットマップをロードする。
ビットマップを取得したいときに使用する。

【宣言】

#If VBA7 Then
    Private 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
#Else
    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
Const IMAGE_BITMAP = 0
Const IMAGE_ICON = 1
Const IMAGE_CURSOR = 2
Const LR_DEFAULTCOLOR = &H0
Const LR_MONOCHROME = &H1
Const LR_LOADFROMFILE = &H10
Const LR_LOADTRANSPARENT = &H20
Const LR_DEFAULTSIZE = &H40
Const LR_LOADMAP3DCOLORS = &H1000
Const LR_CREATEDIBSECTION = &H2000
Const LR_SHARED = &H8000

hinst・・・インスタンスのハンドル
lpszName・・・イメージの名前または識別子
uType・・・イメージのタイプ
cxDesired・・・希望する幅
cyDesired・・・希望する高さ
fuLoad・・・ロードのオプション

LR_DEFAULTCOLOR・・・デフォルト。「LR_MONOCHROME」でないと意味する
LR_MONOCHROME・・・白黒イメージとしてロード
LR_LOADFROMFILE・・・外部ファイルからロード。指定がないとリソースの名前と認識
LR_LOADTRANSPARENT・・・最初のピクセルを取得し、対応するウィンドウカラーに置き換える
LR_DEFAULTSIZE・・・幅・高さの指定が「0」の場合、システムメトリック値のサイズが使われる
LR_LOADMAP3DCOLORS・・・ColorTableを検索し、該当の灰色を対応する3Dカラーに置換
LR_CREATEDIBSECTION・・・uTypeにIMAGE_BITMAPを指定すると、DIBセクションBMPが返る
LR_SHARED = &H8000・・・イメージを2回以上ロードする場合に、同じハンドルを使う

定数は多くあるが、外部からビットマップファイルをロードするだけなら、LR_LOADFROMFILEのみの宣言で良い。尚、LoadImage関数でロードした画像はDeleteObject関数で破棄する。
使用例のサンプルコード

SelectObject関数

指定したDC（デバイスコンテキスト）に、指定したオブジェクトを選択。
DCに、ロードしたBMPを設定したり、ペン・ブラシやフォントなどの属性を設定する場合に使用。

【宣言】

#If VBA7 Then
    Declare PtrSafe Function SelectObject Lib "gdi32" ( _
        ByVal hDC As LongPtr, _
        ByVal hObject As LongPtr) As LongPtr
#Else
    Declare Function SelectObject Lib "gdi32" ( _
        ByVal hDC As Long, _
        ByVal hgdiobj As Long) As Long
#End If

hdc・・・DCのハンドルを指定。
hgdiobj・・・選択対象のオブジェクトのハンドルを指定。
この関数は、指定したものと同じタイプで、それまで選択されていたオブジェクトを返す。
新しいオブジェクトを使い終えたら、元のオブジェクトを選択し直す。
使用例のサンプルコード

DeleteObject関数

ペン、ブラシ、フォント、ビットマップ、リージョン、パレットなどのオブジェクトを削除。
そのオブジェクトに関連付けられていたすべてのシステムリソースを解放。オブジェクトを削除した後は、指定されたハンドルは無効になる。
LoadImage関数で読み込んだBMPを削除する場合などに使用。

【宣言】

#If VBA7 Then
    Declare PtrSafe Function DeleteObject Lib "gdi32" ( _
        ByVal hObject As LongPtr) As Long
#Else
    Declare Function DeleteObject Lib "gdi32" ( _
        ByVal hObject As Long) As Long
#End If

hObject・・・ペン、ブラシ、フォント、ビットマップなどのオブジェクトのハンドルを指定。
使用例のサンプルコード

CreateDIBSection関数

デバイス独立のビットマップ（DIB）を作成。

【宣言】

#If VBA7 Then
    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
#Else
    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
#End If

【引数】
hDC・・・DCのハンドル。iUsageがDIB_PAL_COLORSの場合、論理パレット使いDIBの色を初期化
pbmi・・・DIB のサイズや色情報などの属性を格納しているビットマップデータ
iUsage・・・BITMAPINFO構造体のbmiColorsメンバの配列データ種類の指定
　・DIB_PAL_COLORS　hdcに指定のDCの論理パレットに関係する16ビットのインデックス番号
　・DIB_RGB_COLORS　BITMAPINFO 構造体は RGB 値からなる配列を保持
ppvBits・・・ビット値。ここの変数に、DIBのビット値が置かれている場所が格納される
hSection・・・DIBを作成するために、関数が使うファイルマッピングオブジェクトのハンドルを指定
dwOffset・・・ビットマップのビット値へのオフセット
使用例のサンプルコード

GetDIBits関数

指定されたビットマップのビットを取得し、指定された形式でバッファへコピー。

【宣言】

#If VBA7 Then
    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
#Else
    Private Declare Function GetDIBits Lib "gdi32" ( _
        ByVal hDC As Long, _
        ByVal hBmp As Long, _
        ByVal nStartScan As Long, _
        ByVal cScanLines As Long, _
        lpvBits As Any, _
        lpBI As BITMAPINFO, _
        ByVal uUsage As Long) As Long
#End If

【引数】
hDC・・・DCのハンドルを指定
hBmp・・・ビットマップのハンドルを指定
nStartScan・・・取得対象の最初の走査行を指定
cScanLines・・・取得対象の走査行の数を指定
lpBI・・・ビットマップデータのバッファ。DIBデータを保持している、BITMAPINFO構造体を指定
uUsage・・・BITMAPINFO 構造体のbmiColorsメンバの形式を指定
　・DIB_PAL_COLORS　hdcに指定のDCの論理パレットに関係する16ビットのインデックス番号
　・DIB_RGB_COLORS　BITMAPINFO 構造体は RGB 値からなる配列を保持

関数使用サンプルコード

これまでのオブジェクトに関連する関数を使用したサンプル。
選択しているセルの背景色を、ビットマップ画像に変換するサンプルコード。
※下記のコードを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

トップ　>　備忘録　>　オブジェクト関連