VBAでビットマップ(bmp)を読み書き

会社のPCでは自由にソフトウェアをインストールすることができないので、業務で使いそうなものはExcel VBAで自作していくことにした。 まずは手始めに24ビットビットマップの読み書きを行う標準モジュールを作成した。 VBAの機能のみで実装しており、外部のライブラリには依存しない。

使い方

  • 以下のソースをOfficeのマクロで標準モジュールとしてプロジェクトへ追加する。
  • ReadBitmap(“C:***.bmp”)で、RGBTRIPLE型の2次元配列が返る。
  • 読み込みは一応1, 4, 8, 24, 32ビットのビットマップファイルに対応。
  • WriteBitmap24(“C:***.bmp”)で24ビットのビットマップファイルを書き込む。
  • おまけ機能として、ReadGIFJPEGでGIFとJPEGファイルも読み込みにも対応。

    ' Bitmap module by 330k
    ' Copyright (C) 2010 330k, All rights reserved.
    Option Explicit
    
    Public Type RGBTRIPLE
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    End Type
    
    Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
    End Type
    Private Type BITMAPFILEHEADER
    bfType As String * 2
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bjOffBits As Long
    End Type
    Private Type BitmapInfoHeader
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImaze As Long
    biXPixPerMeter As Long
    biYPixPerMeter As Long
    biClrUsed As Long
    biClrImporant As Long
    End Type
    
    ' Read a bitmap file (1, 4, 8, 24 and 32 bit) and return image as 2-dimension array of RGBTriple
    Public Function ReadBitmap(strFileName As String) As RGBTRIPLE()
    Dim i As Long
    Dim j As Long
    Dim n As Long
    Dim intFileNumber As Integer
    Dim bjHeader As BITMAPFILEHEADER
    Dim biHeader As BitmapInfoHeader
    Dim lngColors As Long
    Dim rgbData() As RGBTRIPLE
    Dim rgbTemp As RGBTRIPLE
    Dim rgbTable3() As RGBTRIPLE
    Dim rgbTable4() As RGBQUAD
    Dim bytTemp As Byte
        
    intFileNumber = FreeFile()
    Open strFileName For Binary As intFileNumber
        Get intFileNumber, , bjHeader
        Get intFileNumber, , biHeader
            
        ReDim rgbData(0 To biHeader.biHeight - 1, 0 To biHeader.biWidth - 1) As RGBTRIPLE
        n = (4 - (-(Int(-biHeader.biWidth * (biHeader.biBitCount / 8))) Mod 4)) Mod 4
        lngColors = IIf(biHeader.biClrUsed = 0, 2 ^ biHeader.biBitCount, biHeader.biClrUsed)
            
        Select Case biHeader.biBitCount
        Case 1
            ReDim rgbTable4(0 To lngColors - 1) As RGBQUAD
            Get intFileNumber, , rgbTable4
            rgbTable3 = ConvertRGBQuadToRGBTriple(rgbTable4)
                
            For i = UBound(rgbData, 1) To 0 Step -1
                For j = 0 To UBound(rgbData, 2) Step 8
                    Get intFileNumber, , bytTemp
                        
                    rgbData(i, j) = rgbTable3(bytTemp \ 128)
                    If j + 1 <= UBound(rgbData, 2) Then rgbData(i, j + 1) = rgbTable3(bytTemp \ 64 And 1)
                    If j + 2 <= UBound(rgbData, 2) Then rgbData(i, j + 2) = rgbTable3(bytTemp \ 32 And 1)
                    If j + 3 <= UBound(rgbData, 2) Then rgbData(i, j + 3) = rgbTable3(bytTemp \ 16 And 1)
                    If j + 4 <= UBound(rgbData, 2) Then rgbData(i, j + 4) = rgbTable3(bytTemp \ 8 And 1)
                    If j + 5 <= UBound(rgbData, 2) Then rgbData(i, j + 5) = rgbTable3(bytTemp \ 4 And 1)
                    If j + 6 <= UBound(rgbData, 2) Then rgbData(i, j + 6) = rgbTable3(bytTemp \ 2 And 1)
                    If j + 7 <= UBound(rgbData, 2) Then rgbData(i, j + 7) = rgbTable3(bytTemp And 1)
                        
                Next
                For j = 1 To n
                    Get intFileNumber, , bytTemp
                Next
            Next
                
        Case 4
            ReDim rgbTable4(0 To lngColors - 1) As RGBQUAD
            Get intFileNumber, , rgbTable4
            rgbTable3 = ConvertRGBQuadToRGBTriple(rgbTable4)
                
            For i = UBound(rgbData, 1) To 0 Step -1
                For j = 0 To UBound(rgbData, 2) Step 2
                    Get intFileNumber, , bytTemp
                        
                    rgbData(i, j) = rgbTable3(bytTemp \ 16)
                    If j + 1 <= UBound(rgbData, 2) Then rgbData(i, j + 1) = rgbTable3(bytTemp And 15)
                Next
                For j = 1 To n
                    Get intFileNumber, , bytTemp
                Next
            Next
                
        Case 8
            ReDim rgbTable4(0 To lngColors - 1) As RGBQUAD
            Get intFileNumber, , rgbTable4
            rgbTable3 = ConvertRGBQuadToRGBTriple(rgbTable4)
                
            For i = UBound(rgbData, 1) To 0 Step -1
                For j = 0 To UBound(rgbData, 2)
                    Get intFileNumber, , bytTemp
                    rgbData(i, j) = rgbTable3(bytTemp)
                Next
                For j = 1 To n
                    Get intFileNumber, , bytTemp
                Next
            Next
                
        Case 24
            For i = UBound(rgbData, 1) To 0 Step -1
                For j = 0 To UBound(rgbData, 2)
                    Get intFileNumber, , rgbData(i, j)
                Next
                For j = 1 To n
                    Get intFileNumber, , bytTemp
                Next
            Next
                
        Case 32
            ReDim rgbTable4(0 To biHeader.biHeight - 1, 0 To biHeader.biWidth - 1) As RGBQUAD
                
            Get intFileNumber, , rgbTable4
            rgbData = ConvertRGBQuadToRGBTriple2(rgbTable4)
                
        End Select
    Close
        
    ReadBitmap = rgbData
    End Function
    
    ' Write a bitmap file (24-bit only) from 2-dimension array of RGBTriple
    Public Sub WriteBitmap24(strFileName As String, rgbData() As RGBTRIPLE)
    Dim i As Long
    Dim j As Long
    Dim n As Long
    Dim lngWidth As Long
    Dim lngHeight As Long
    Dim intFileNumber As Integer
    Dim bjHeader As BITMAPFILEHEADER
    Dim biHeader As BitmapInfoHeader
    Dim bytTemp As Byte
        
    lngHeight = UBound(rgbData, 1) + 1
    lngWidth = UBound(rgbData, 2) + 1
    n = (4 - (lngWidth * 3 Mod 4)) Mod 4
        
    With bjHeader
        .bfType = "BM"
        .bfSize = Len(bjHeader) + Len(biHeader) + 3 * lngHeight * lngWidth
        .bjOffBits = Len(bjHeader) + Len(biHeader)
    End With
    With biHeader
        .biSize = 40
        .biWidth = lngWidth
        .biHeight = lngHeight
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = 0
        .biSizeImaze = 3 * lngHeight * lngWidth
        .biXPixPerMeter = 3780
        .biYPixPerMeter = 3780
        .biClrUsed = 0
        .biClrImporant = 0
    End With
        
    If Len(Dir(strFileName)) Then
        Kill strFileName
    End If
        
    intFileNumber = FreeFile()
    Open strFileName For Binary As intFileNumber
        Put intFileNumber, , bjHeader
        Put intFileNumber, , biHeader
            
        For i = lngHeight - 1 To 0 Step -1
            For j = 0 To lngWidth - 1
                Put intFileNumber, , rgbData(i, j)
            Next
            For j = 1 To n
                Put intFileNumber, , bytTemp
            Next
        Next
    Close
    End Sub
    
    ' Read GIF or JPEG files as RGBTRIPLE()
    Public Function ReadGIFJPEG(strFileName As String) As RGBTRIPLE()
    Dim objPicture As IPictureDisp
    Dim strTempFile As String
        
    Set objPicture = LoadPicture(strFileName)
    strTempFile = GetTempName()
        
    SavePicture objPicture, strTempFile
        
    ReadGIFJPEG = ReadBitmap(strTempFile)
        
    Kill strTempFile
    End Function
    
    ' Private Functions
    Private Function ConvertRGBQuadToRGBTriple(rgbSource() As RGBQUAD) As RGBTRIPLE()
    Dim i As Long
    Dim j As Long
    Dim rgbResult() As RGBTRIPLE
        
    ReDim rgbResult(0 To UBound(rgbSource, 1)) As RGBTRIPLE
        
    For i = 0 To UBound(rgbSource, 1)
        rgbResult(i).rgbBlue = rgbSource(i).rgbBlue
        rgbResult(i).rgbGreen = rgbSource(i).rgbGreen
        rgbResult(i).rgbRed = rgbSource(i).rgbRed
    Next
        
    ConvertRGBQuadToRGBTriple = rgbResult
    End Function
    
    Private Function ConvertRGBQuadToRGBTriple2(rgbSource() As RGBQUAD) As RGBTRIPLE()
    Dim i As Long
    Dim j As Long
    Dim rgbResult() As RGBTRIPLE
        
    ReDim rgbResult(0 To UBound(rgbSource, 1), 0 To UBound(rgbSource, 2)) As RGBTRIPLE
        
    For i = 0 To UBound(rgbSource, 1)
        For j = 0 To UBound(rgbSource, 2)
            rgbResult(i, j).rgbBlue = rgbSource(i, j).rgbBlue
            rgbResult(i, j).rgbGreen = rgbSource(i, j).rgbGreen
            rgbResult(i, j).rgbRed = rgbSource(i, j).rgbRed
        Next
    Next
        
    ConvertRGBQuadToRGBTriple2 = rgbResult
    End Function