もう一度、ExcelでBitmap

　以前、Excel VBAでBitmap画像を作るプログラムを作りました。お気づきの方?もいるかもしれませんが、以前のプログラムでは画像の幅が4の倍数のみしか扱えません。
　理由はめんどくさかったからです。

　今回、画像処理でもして遊ぼうかなぁと思ったんですが、いろいろな画像で遊ぶために、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の倍数)
'24bitカラーの場合、1ラインのデータ長(byte単位)は 3 * width + width mod 4 とすれば、とりあえずOK
'--------------------------------------------------

Public Const PI = 3.1415926535

'<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 bitmap_test()
    Dim i As Long
    Dim j As Long
    Dim width As Long
    Dim height As Long
    Dim lineSize As Long
    Dim pos As Long
    Dim data() As Byte
    Dim filename As String
 
    '------------------------------
    'データの作成
    width = 127
    height = 128
    lineSize = 3 * width + width Mod 4
    ReDim data(lineSize * height - 1) As Byte
 
    For i = 0 To height - 1
        For j = 0 To width - 1
            pos = lineSize * i + j * 3
            data(pos + 0) = CByte(255 / width * j)  'Blue
            data(pos + 1) = CByte(255 / height * i) 'Green
            data(pos + 2) = CByte(255 - 127 / width * j - 127 / height * i) 'Red
         
            If j Mod 8 = 0 Or i Mod 8 = 0 Then
                data(pos + 0) = 0
                data(pos + 1) = 0
                data(pos + 2) = 255
            End If
        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)

    '1ラインのデータ長(byte単位)は、4の倍数でないとダメ
    If UBound(data) <> (3 * width + width Mod 4) * height - 1 Then GoTo Label1
 
    bfHeader.bfType = "BM"
    bfHeader.bfSize = UBound(data) + 1 + 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 = UBound(data) + 1
    biHeader.biXPixPerMeter = 0
    biHeader.biYPixPerMeter = 0
    biHeader.biClrUsed = 0
    biHeader.biClrImportant = 0
 
    On Error GoTo Label1
 
    Open filename For Binary As 1
        Put 1, , bfHeader
        Put 1, , biHeader
        Put 1, , data
    Close 1
 
    Exit Sub
 
Label1:
    Close 1
    MsgBox "Error (writeBitmap)", vbExclamation
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 - 1) As Byte
        Get 1, , data

        width = biHeader.biWidth
        height = biHeader.biHeight
    Close 1
 
    '1ラインのデータ長(byte単位)は、4の倍数でないとダメ
    If UBound(data) <> (3 * width + width Mod 4) * height - 1 Then GoTo Label1
 
    Exit Sub
 
Label1:
    Close 1
    MsgBox "Error (readBitmap)", vbExclamation
End Sub