【Excel】セル上にBMP画像を展開する。VBA
2週間くらい前？のホッテントリに、Excel上に画像を描く(セルを塗る)記事が載っていました。
これくらいなら自分でも作れそうだなと思ったので、VBAで実装してみます。
今回画像の展開をし、次回以降、画像処理をやる予定です(VBAで)。
はじめに
さて、VBAで画像を読み込んでセル上に展開するわけですが、VBで画像ファイルを配列化する関数を知りません。今回画像の読み込みは、BMPファイルのバイナリを読み込んで配列化しようと思います。そして、その配列をセル上に展開して画像を表示します。
バイナリで読み込めるようになれば、もうブラックボックスなんて存在しない！
BMPは、Jpegやpngと違って圧縮されていないので簡単に扱えます。
最終的にこうなります。
BMPファイルの読み込み
BMPファイルのフォーマットは以下を参照してください。
ぶっちゃけ読み込みだけを考えたときに重要となるのは、
- [10] bfOffBits 4byte
- ファイル先頭から画像データまでのオフセット[byte]
- [18] biWidth 4byte
- 画像の幅[ピクセル]
- [22] biHeight 4byte
- 画像の高さ[ピクセル]
- ファイル末尾に画像上部の画素値がある。
- 画像がひっくり返ってファイルに入っている
- 画像の行単位で、byte数が4の倍数になるように、0が追加されている
- 例えば横ピクセル数が198だったら0byteが2つ足されている
の5点です。[数値]はファイル先頭から何Byte目かを表しています。
怒られそうですが、簡単にするため、読み込むBMPファイルは、24Bit1677万色のビットマップだけとします(MSペイントで保存した場合、これになります)。
バイナリモードでファイルを読み込みます。
ChDir ThisWorkbook.Path & "\" openFileName = Application.GetOpenFilename("BMP画像,*.bmp") If openFileName = "False" Then MsgBox "BMPファイルを選択してください" Exit Sub End If 'ファイルをバイナリーモードで開き、1次元配列a()に入れる Open openFileName For Binary As #1 File_Size = LOF(1) ReDim a(File_Size) Get #1, , a() Close #1
3次元(縦×横×RGB)に配列化
ファイルの読み込みが終わったら、扱いやすいように3次元(縦×横×RGB)の配列にしていきます。
横ピクセル数が[18]から4byte、縦ピクセル数を[22]から4byteに書いてあるのでそれを取り出し、3次元(縦ピクセル×横ピクセル×3)配列image()を作成する。
そして、BMPファイルの入った1次元配列a()の末尾から順に、3次元配列image()に入れていく。
Image_Width_Pixel = myHex2Dec(a(), WIDTH_POS, WIDTH_POS + 3) Image_Height_Pixel = myHex2Dec(a(), HEIGHT_POS, HEIGHT_POS + 3) Line_Width_Size = myCalcLineSize(Image_Width_Pixel) Line_Last_Size = Line_Width_Size - Image_Width_Pixel * 3 Image_Data_Pos = myHex2Dec(a(), 10, 13) ReDim image(Image_Width_Pixel - 1, Image_Height_Pixel - 1, 3 - 1) Call WriteImage2Array(image(), a(), File_Size)
'byte列(a())を3次元配列(image(x,y,color))にいれる Function WriteImage2Array(image() As Byte,a() As Byte,fileSize As Long) Dim r As Long Dim c As Long Dim color As Long Dim rMax As Long Dim cMax As Long Dim i As Long rMax = UBound(image, 2) cMax = UBound(image, 1) i = fileSize - 1 For r = 0 To rMax For c = cMax To 0 Step -1 For color = 0 To 2 image(c, r, color) = a(i) i = i - 1 Next Next Next End Function
セル上に配列を展開
セルの幅を自動調節し、
3次元(縦ピクセル×横ピクセル×3)配列image()をA1,A2,...,B1,B2,......と順番に塗っていくことで完成！！
Function WriteArray2Cells(a() As Byte)
Dim r As Long
Dim c As Long
Dim color As Long
Dim rMax As Long
Dim cMax As Long
rMax = UBound(a, 2)
cMax = UBound(a, 1)
Application.ScreenUpdating = False
For r = 0 To rMax
For c = 0 To cMax
Cells(r + 1, c + 1).Interior.color = RGB(a(c, r, 0), a(c, r, 1), a(c, r, 2))
Next
Next
Application.ScreenUpdating = True
End Function
画像の保存
バイナリをいじって画像を保存するのは自信がないため、画像が展開されたセルをコピーし、MSペイントに貼り付けることで画像の保存に対応しました！！荒業
Function WriteImage2Jpeg(image() As Byte)
Dim r As Long
Dim c As Long
r = UBound(image, 2) + 1
c = UBound(image, 1) + 1
Dim rc As Long
Range(Cells(1, 1), Cells(r, c)).CopyPicture
rc = Shell("mspaint", vbNormalFocus)
Application.Wait Now + TimeValue("00:00:01")
SendKeys "^v", True
SendKeys "^s", True
End Function
