Excel VBAでBitmapファイルを操作するモジュールを作ってみました。各ピクセルに適当な色を設定して、Bitmapファイルに保存する、みたいなことができます。
ソースコードを以下に載せます。VBAのモジュールにコピペすれば使えるはずです。
Bitmapファイルの詳細についてはWikipedia等を参照ください。
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
********************************************************************************
0 件のコメント:
コメントを投稿