ビットマップ画像の作成

ビットマップ画像の作成

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


サンプルコード

選択しているセルの背景色を、ビットマップ画像に変換するサンプルコード。
※下記のコードを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

メモ

◆TypeName関数
 変数に関する情報を提供する文字列型 (String) の文字列を返す。

 構文:TypeName(varname)

 [varname]
  任意のバリアント型 (Variant) の変数必ず指定。
【補足】
 TypeName 関数によって次のいずれかの文字列が返る。

 varnameが配列の場合、上記の該当する文字列に、空のかっこ "()" がつく。
 例えば、varnameが整数の配列では "Integer()" を返す。

◆FreeFile関数
 使用可能なファイル番号を整数型 (Integer) の値で返す。
 既に使われているファイル番号を重複して使うのを防ぐことができる。

 構文:FreeFile[(rangenumber)]

 [rangenumber]
  省略可。ファイル番号の範囲をバリアント型 (Variant) で指定。
  指定した範囲から次に使用可能なファイル番号を返す。

◆Application.GetSaveAsFilenameメソッド
 [ 参照 ]

◆Open/Closeステートメント
 後日記載

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

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

◆Patblt/SetPixel関数(Win32API)
 後日記載

Excel Tips for Teachers

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