Memorandum

ビットマップ画像の作成

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

サンプルコード

選択しているセルの背景色を、ビットマップ画像に変換するサンプルコード。
セルの高さや幅に関係なく、1セルは縦横1ピクセルのBMPに変換される。
※下記のコードをVBEに貼り付ると、一部赤く表示される場合があるが、エラーではない。
※対応するセル範囲の大きさは320×320セル
※次のコードを利用したソフト:「画像とセル背景色の相互変換」アドイン

'///宣言セクションに記述///
#If VBA7 Then
    '64ビット
    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

メモ

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(Win32API)

[ 参照 ]

CreateDIBSection/GetDIBits関数関数(Win32API)

[ 参照 ]

Patblt/SetPixel関数(Win32API)

後日記載

ページトップへ戻る
Copyright(C) 2009- 坂江保 All Rights Reserved.