エクセルシートにビットマップ画像を表示するExcel VBAプログラム

動機

世の中にはExcelを使ってお絵描きをする人という方がいらっしゃいます。
自分は絵心がないのでビットマップファイルをロードして、エクセルシートの背景色の１ビットごとに色付けをするかたちで絵を描くプログラムを作成しました。
かなり雑なプログラムなので動かないこともあるかもしれません。

プログラム

bitmapviewer.bas

Option Explicit


'BITMAPFILEHEADER ヘッダー情報
Dim bfType As String
Dim bfSize As Long
Dim bfReserved1 As Integer
Dim bfReserved2 As Integer
Dim bfOffBits As Long


'BITMAPINFOHEADER ヘッダー情報
Dim bcSize As Long
Dim bcWidth As Long
Dim bcHeight As Long
Dim bcPlanes As Integer
Dim bcBitcount As Integer
Dim biCompression As Long
Dim biSizeImage As Long
Dim biXPixPerMeter As Long
Dim biYPixPerMeter As Long
Dim biClrUsed As Long
Dim biCirImportant As Long

'BITMAPFILEHEADER 操作手続き
Private Sub readBITMAPFILEHEADER(ByRef buf() As Byte)
    bfType = Chr(buf(0)) + Chr(buf(1))
    bfSize = concat4LEndian(buf(), 2)
    bfReserved1 = concat2LEndian(buf(), 6)
    bfReserved2 = concat2LEndian(buf(), 8)
    bfOffBits = concat4LEndian(buf(), 10)
End Sub

Private Sub showBITMAPFILEHEADER()
    Debug.Print "bfType:", bfType
    Debug.Print "bfSize:", bfSize
    Debug.Print "bfReserved1:", bfReserved1
    Debug.Print "bfReserved2:", bfReserved2
    Debug.Print "bfOffBits:", bfOffBits
End Sub

'BITMAPINFOHEADER 操作手続き
Public Sub readBITMAPINFOHEADER(ByRef buf() As Byte)
    bcSize = concat4LEndian(buf(), 0)
    bcWidth = concat4LEndian(buf(), 4)
    bcHeight = concat4LEndian(buf(), 8)
    bcPlanes = concat2LEndian(buf(), 12)
    bcBitcount = concat2LEndian(buf(), 14)
    biCompression = concat4LEndian(buf(), 16)
    biSizeImage = concat4LEndian(buf(), 20)
    biXPixPerMeter = concat4LEndian(buf(), 24)
    biYPixPerMeter = concat4LEndian(buf(), 28)
    biClrUsed = concat4LEndian(buf(), 32)
    biCirImportant = concat4LEndian(buf(), 36)
End Sub

Private Sub showBITMAPINFOHEADER()
    Debug.Print "bcSize:", bcSize
    Debug.Print "bcWidth:", bcWidth
    Debug.Print "bcHeight:", bcHeight
    Debug.Print "bcPlanes:", bcPlanes
    Debug.Print "bcBitcount:", bcBitcount
    Debug.Print "biCompression:", biCompression
    Debug.Print "biSizeImage:", biSizeImage
    Debug.Print "biXPixPerMeter:", biXPixPerMeter
    Debug.Print "biYPixPerMeter:", biYPixPerMeter
    Debug.Print "biClrUsed:", biClrUsed
    Debug.Print "biCirImportant:", biCirImportant
End Sub

'プライベート共通手続き、関数
Private Function left_shift(ByVal b, ByVal shift As Byte)
    Dim bit As Long: bit = b
    left_shift = bit * (2 ^ shift)
End Function

Private Function concat2LEndian(ByRef buf() As Byte, ByVal initIndex)
    concat2LEndian = left_shift(buf(initIndex + 1), 8) Or buf(initIndex)
End Function

Private Function concat4LEndian(ByRef buf() As Byte, ByVal initIndex)
    concat4LEndian = left_shift(buf(initIndex + 3), 24) Or left_shift(buf(initIndex + 2), 16) Or left_shift(buf(initIndex + 1), 8) Or buf(initIndex)
End Function
 

'メイン手続き

Public Sub displayBitmapImage(ByVal fpath As String)
    Dim fn As Integer: fn = FreeFile
    Open fpath For Binary Access Read As #fn
    
    Dim wholeSize As Long: wholeSize = LOF(fn)
    Dim sizeFileHeader As Integer: sizeFileHeader = 14 - 1
    Dim sizeInfoHeader As Integer: sizeInfoHeader = 40 - 1
    Dim bufArry() As Byte
    
    Debug.Print "displayBitmapImage"
    
    If (sizeFileHeader + sizeInfoHeader <= wholeSize) Then
        ReDim bufArry(sizeFileHeader)
        Get #fn, , bufArry
        Call readBITMAPFILEHEADER(bufArry)
        Call showBITMAPFILEHEADER
        ReDim bufArry(sizeInfoHeader)
        Get #fn, , bufArry
        Call readBITMAPINFOHEADER(bufArry)
        Call showBITMAPINFOHEADER
    Else
        Exit Sub
    End If
    
    Dim sizeLineBuf As Integer: sizeLineBuf = (3 * bcWidth) - 1
    Dim lineNum As Long: lineNum = bcHeight
    Dim iReadSize As Long: iReadSize = sizeFileHeader + 1 + sizeInfoHeader + 1
    ReDim bufArry(sizeLineBuf)
    
    Do Until EOF(fn)
        Get #fn, , bufArry
        Call coloring(lineNum, bufArry, Range("A1").Offset(lineNum, 0))
        lineNum = lineNum - 1
        iReadSize = iReadSize + sizeLineBuf + 1
        If (iReadSize <= wholeSize) And (wholeSize - iReadSize < sizeLineBuf + 1) Then
            sizeLineBuf = wholeSize - iReadSize
            ReDim bufArry(sizeLineBuf)
        End If
        DoEvents
    Loop
    Close #fn
End Sub


Private Sub coloring(ByVal lnum As Long, ByRef lbuf() As Byte, ByRef rng As Range)
    Dim R24 As Byte
    Dim G24 As Byte
    Dim B24 As Byte
    
    Dim it As Long
    For it = LBound(lbuf) To UBound(lbuf) - 3 Step 3
        B24 = lbuf(it)
        G24 = lbuf(it + 1)
        R24 = lbuf(it + 2)
        rng.Offset(0, it \ 3).Interior.Color = RGB(R24, G24, B24)
    Next it
    'Debug.Print RGB(R24, G24, B24)
End Sub


Public Sub main()
    Sheets(1).Cells.Select
    Selection.ColumnWidth = 0.06
    Selection.RowHeight = 0.6
    Dim filename As String: filename = Application.GetOpenFilename("ビットマップファイル,*.bmp")
    If filename = "False" Then Exit Sub
    Call displayBitmapImage(filename)
End Sub