vba - 使用 VBA 创建 BMP 图像

Question

我试图创建一个将单元格的值转换为 BMP 文件的宏。

代码基于现有主题，可在此处找到:
VBA manually create BMP

Type typHEADER
    strType As String * 2  ' Signature of file = "BM"
    lngSize As Long        ' File size
    intRes1 As Integer     ' reserved = 0
    intRes2 As Integer     ' reserved = 0
    lngOffset As Long      ' offset to the bitmap data (bits)
End Type

Type typINFOHEADER
    lngSize As Long        ' Size
    lngWidth As Long       ' Height
    lngHeight As Long      ' Length
    intPlanes As Integer   ' Number of image planes in file
    intBits As Integer     ' Number of bits per pixel
    lngCompression As Long ' Compression type (set to zero)
    lngImageSize As Long   ' Image size (bytes, set to zero)
    lngxResolution As Long ' Device resolution (set to zero)
    lngyResolution As Long ' Device resolution (set to zero)
    lngColorCount As Long  ' Number of colors (set to zero for 24 bits)
    lngImportantColors As Long ' "Important" colors (set to zero)
End Type

Type typPIXEL
    bytB As Byte    ' Blue
    bytG As Byte    ' Green
    bytR As Byte    ' Red
End Type

Type typBITMAPFILE
    bmfh As typHEADER
    bmfi As typINFOHEADER
    bmbits() As Byte
End Type

Sub testowy()
    Dim bmpFile As typBITMAPFILE
    Dim lngRowSize As Long
    Dim lngPixelArraySize As Long
    Dim lngFileSize As Long
    Dim j, k, l, x As Integer
    Dim bytRed, bytGreen, bytBlue As Integer
    Dim lngRGBColoer() As Long

    Dim strBMP As String

    With bmpFile

        With .bmfh
            .strType = "BM"
            .lngSize = 0
            .intRes1 = 0
            .intRes2 = 0
            .lngOffset = 54
        End With
        With .bmfi
            .lngSize = 40
            .lngWidth = 21
            .lngHeight = 21
            .intPlanes = 1
            .intBits = 24
            .lngCompression = 0
            .lngImageSize = 0
            .lngxResolution = 0
            .lngyResolution = 0
            .lngColorCount = 0
            .lngImportantColors = 0
        End With
        lngRowSize = Round(.bmfi.intBits * .bmfi.lngWidth / 32) * 4
        lngPixelArraySize = lngRowSize * .bmfi.lngHeight

        ReDim .bmbits(lngPixelArraySize)
        ReDim lngRGBColor(21, 21)
        For j = 1 To 21  ' For each row, starting at the bottom and working up...
            'each column starting at the left
            For x = 1 To 21
                If Cells(j, x).Value = 1 Then
                    k = k + 1
                    .bmbits(k) = 0
                    k = k + 1
                    .bmbits(k) = 0
                    k = k + 1
                    .bmbits(k) = 0
                Else
                    k = k + 1
                    .bmbits(k) = 255
                    k = k + 1
                    .bmbits(k) = 255
                    k = k + 1
                    .bmbits(k) = 255
                End If
            Next x
        Next j
        .bmfh.lngSize = 14 + 40 + lngPixelArraySize
     End With ' Defining bmpFile
    strBMP = "C:\Lab\xxx.BMP"
    Open strBMP For Binary Access Write As 1 Len = 1
        Put 1, 1, bmpFile.bmfh
        Put 1, , bmpFile.bmfi
        Put 1, , bmpFile.bmbits
    Close
End Sub

输出与我的预期有很大不同(左 - 实际输出，右 - 预期输出)。

Answer 1

代码中有一个小错误。
BMP 文件中的颜色保存为: [B,G,R] 第一个像素 [B,G,R] 第二个像素 [0,0] 填充(间隙)，用于 4 字节对齐。要镜像图像，应反转第一个循环。正确的代码(包括循环)应该是这样的:

        k = -1
    For j = 21 To 1 Step -1
    ' For each row, starting at the bottom and working up...
        'each column starting at the left
        For x = 1 To 21                
           If Cells(j, x).Value = 1 Then
                k = k + 1
                .bmbits(k) = 0
                k = k + 1
                .bmbits(k) = 0
                k = k + 1
                .bmbits(k) = 0
            Else
                k = k + 1
                .bmbits(k) = 255
                k = k + 1
                .bmbits(k) = 255
                k = k + 1
                .bmbits(k) = 255
            End If
        Next x

        If (21 * .bmfi.intBits / 8 < lngRowSize) Then   ' Add padding if required
            For l = 21 * .bmfi.intBits / 8 + 1 To lngRowSize
                k = k + 1
                .bmbits(k) = 0
            Next l
        End If
    Next j