以前、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
0 件のコメント:
コメントを投稿