ExcelでBitmap

　Bitmapファイルのピクセルを編集したい、ってことありますよね(?)

　Excel VBAでBitmapファイルを操作するモジュールを作ってみました。各ピクセルに適当な色を設定して、Bitmapファイルに保存する、みたいなことができます。

　ソースコードを以下に載せます。VBAのモジュールにコピペすれば使えるはずです。

　Bitmapファイルの詳細についてはWikipedia等を参照ください。

興味ある方は、ご自由にご利用ください。(・・・保証はありませんが orz)


2016/1/4
変数を構造体に変更しました。わざわざ構造体にしなくてもいいんですが、気分です。


********************************************************************************

Option Explicit

'--------------------------------------------------
'Bitmapファイルの構造
'<BITMAPFILEHEADER構造体> + <BITMAPINFOHEADER構造体> + <カラーパレット> + <画像データ>
'--------------------------------------------------
'<BITMAPFILEHEADER構造体>
'bfType         2bytes  "BM"
'bfSize         4bytes  ファイルサイズ, byte単位
'bfReserved1    2bytes  予約領域
'bfReserved2    2bytes  予約領域
'bfOffBits      4bytes  ファイル先頭から画像データまでのオフセット, byte単位
'--------------------------------------------------
'<BITMAPINFOHEADER構造体>
'biSize         4bytes  BITMAPINFOHEADERのサイズ
'biWidth        4bytes  画像の幅, pixel単位
'biHeight       4bytes  画像の高さ, pixel単位
'biPlanes       2bytes  プレーン数, 常に1
'biBitCount     2bytes  1画素当たりのデータサイズ, 1,4,8,24,32bitのいずれか
'biCompression  4bytes  圧縮形式, 無圧縮なら0
'biSizeImage    4bytes  画像データ部のサイズ, 0でもOK
'biXPixPerMeter 4bytes  横方向解像度, 1m当たりの画素数, 0でもOK
'biYPixPerMeter 4bytes  縦方向解像度, 1m当たりの画素数, 0でもOK
'biClrUsed      4bytes  格納されているパレット数, 0でもOK
'biClrImportant 4bytes  重要なパレットのインデックス, 0でもOK
'--------------------------------------------------
'<カラーパレット>
'1, 4, 8bitカラーの場合はカラーパレットのRGB値
'24, 32bitカラーの場合はない
'--------------------------------------------------
'<画像データ>
'1, 4, 8bitカラーの場合は、カラーパレットの値
'24, 32bitカラーの場合は、RGB値の配列
'画像の1ラインのデータ長は4の倍数byteじゃないとダメ (biWidth * biBitCount / 8 が 4の倍数)
'--------------------------------------------------

'<BITMAPFILEHEADER構造体>
Private Type BITMAP_FILE_HEADER
    bfType As String * 2
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type

Private bfHeader As BITMAP_FILE_HEADER

'<BITMAPINFOHEADER構造体>
Private Type BITMAP_INFO_HEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPixPerMeter As Long
    biYPixPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private biHeader As BITMAP_INFO_HEADER



Public Sub test()
    Dim i As Long
    Dim j As Long
    Dim width As Long
    Dim height As Long
    Dim pos As Long
    Dim data() As Byte
    Dim filename As String
   
    '------------------------------
    'データの作成
    width = 256
    height = 128
    ReDim data(width * height * 3 - 1) As Byte
   
    For i = 0 To height - 1
        For j = 0 To width - 1
            pos = (width * i + j) * 3
            data(pos + 0) = CByte(255)              'Blue
            data(pos + 1) = CByte(255 / height * i) 'Green
            data(pos + 2) = CByte(255 / width * j)  'Red
        Next j
    Next i
    '------------------------------
   
    filename = ThisWorkbook.Path + "\test.bmp"
   
    'ファイルに書き出す
    writeBitmap filename, data, width, height
   
    'ファイルから読み込む
    readBitmap filename, data, width, height
End Sub




'Bitmapファイルの書き出し
'24bitフルカラーのみ対応
Public Sub writeBitmap(filename As String, data() As Byte, width As Long, height As Long)

    If width Mod 4 <> 0 Then Exit Sub   '1ラインのデータ長(byte単位)が4の倍数でないとダメ

    bfHeader.bfType = "BM"
    bfHeader.bfSize = width * height * 3 + 54
    bfHeader.bfReserved1 = 0
    bfHeader.bfReserved2 = 0
    bfHeader.bfOffBits = 54
   
    biHeader.biSize = 40
    biHeader.biWidth = width
    biHeader.biHeight = height
    biHeader.biPlanes = 1
    biHeader.biBitCount = 24
    biHeader.biCompression = 0
    biHeader.biSizeImage = width * height * 3
    biHeader.biXPixPerMeter = 0
    biHeader.biYPixPerMeter = 0
    biHeader.biClrUsed = 0
    biHeader.biClrImportant = 0
   
    Open filename For Binary As 1
        Put 1, , bfHeader
        Put 1, , biHeader
        Put 1, , data
    Close 1
End Sub

'Bitmapファイルの読み込み
'24bitフルカラーのみ対応
Public Sub readBitmap(filename As String, ByRef data() As Byte, ByRef width As Long, ByRef height As Long)
    On Error GoTo Label1
   
    Open filename For Binary As 1
        Get 1, , bfHeader
        If bfHeader.bfType <> "BM" Then GoTo Label1
       
        Get 1, , biHeader
        If biHeader.biSize <> 40 Then GoTo Label1
        If biHeader.biBitCount <> 24 Then GoTo Label1
       
        ReDim data(bfHeader.bfSize - bfHeader.bfOffBits) As Byte
        Get 1, , data

        width = biHeader.biWidth
        height = biHeader.biHeight
    Close 1
   
    Exit Sub
   
Label1:
    Close 1
    MsgBox "error", vbExclamation
End Sub

********************************************************************************