オブジェクト関連

オブジェクト関連

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

ポイント

 ・LoadImage関数(Win32API)
 ・SelectObject関数(Win32API)
 ・DeleteObject関数(Win32API)
 ・CreateDIBSection関数(Win32API)
 ・GetDIBits関数(Win32API)


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

LoadImage関数

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

#If VBA7 And Win64 Then
    '64ビット
    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 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 And Win64 Then
    '64ビット
    Declare PtrSafe Function SelectObject Lib "gdi32" ( _
        ByVal hDC As Long, _
        ByVal hObject As Long) As Long
#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 And Win64 Then
    '64ビット
    Declare PtrSafe Function DeleteObject Lib "gdi32" ( _
        ByVal hObject As Long) As Long
#Else
    Declare Function DeleteObject Lib "gdi32" ( _
        ByVal hObject As Long) As Long
#End If

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


CreateDIBSection関数

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

【宣言】

#If VBA7 And Win64 Then
    '64ビット
    Declare PtrSafe 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
#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 And Win64 Then
    '64ビット
    Private Declare PtrSafe 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
#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 And Win64 Then
    '64ビット
    Private Declare PtrSafe 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 PtrSafe Function SetPixel Lib "gdi32" ( _
        ByVal hDC As Long, _
        ByVal x As Long, _
        ByVal y As Long, _
        ByVal crColor As Long) As Long
    Private Declare PtrSafe 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 PtrSafe Function GetDIBits Lib "gdi32" ( _
        ByVal hDC As Long, _
        ByVal hBmp As Long, _
        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 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
#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

Excel Tips for Teachers

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