VBA manually create BMP

问题:

I am working on a VBA class to create QR codes and I am getting stumped at the point where I write the QR data bits to an actual BMP file. To get the hang of the BMP structure and the code I could I have been trying to make a 21 x 21 pixel bitmap of all white using the code below. This almost works, except that the leftmost column in every row is yellow instead of white. Any ideas on what could be happening? I'm guessing there is something wrong with my header definition, but I'm not sure. I am far from a pro at BMPs. My code is based off what I found here http://answers.microsoft.com/en-us/office/forum/office_2007-customize/how-can-i-create-a-bitmap-image-with-vba/4976480a-d20b-4b2a-8ecc-436428d9586b

Private 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
Private 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
Private Type typPIXEL
    bytB As Byte    ' Blue
    bytG As Byte    ' Green
    bytR As Byte    ' Red
End Type
Private Type typBITMAPFILE
    bmfh As typHEADER
    bmfi As typINFOHEADER
    bmbits() As Byte
End Type

'==================================================

Public Sub makeBMP(intQR() As Integer)
    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
                k = k + 1
                .bmbits(k) = 255
                k = k + 1
                .bmbits(k) = 255
                k = k + 1
                .bmbits(k) = 255
            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
        .bmfh.lngSize = 14 + 40 + lngPixelArraySize
     End With ' Defining bmpFile

    strBMP = "C:\Desktop\Sample.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

回答1:

It's a row byte-alignment problem. Pad each row with one extra byte and your problem should vanish.

Posted so that you have an answer to check off. :)

Also, here is a good bmp tool. https://50ab6472f92ea10153000096.openlearningapps.net/run/view

回答2:

There is a small error in this BMP export code.
the line that says

lngRowSize = Round(.bmfi.intBits * .bmfi.lngWidth / 32) * 4

should actually say

'old line:    lngRowSize = Round(.bmfi.intBits * .bmfi.lngWidth / 32) * 4
 lngRowSize = WorksheetFunction.Ceiling_Precise(.bmfi.intBits * .bmfi.lngWidth / 32) * 4

Before, the round function prevented certain image widths from exporting correctly, and the code threw an error. Previously rejected widths: (3,6,7,11,14,15,19,22,23,27,30,...)

I assume you no longer need this code, but I copied it from here and I figure someone else will too.

回答3:

I ran your code to verify the yellow line. After looking at it closely I believe the problem could be solved by setting the bounds of your bmpfile.bmpbits byte array. When you defined the array you left the lower bound empty and therefore the array by default will start at 0. If you re-dim the array like this

    ReDim .bmbits(1 To lngPixelArraySize)

You will get a solid white sample.bmp. I ran it to verify and it worked for me.

Good luck. I could see how making k start at -1 would work. The only problem that remains is that your array size will have one extra byte.

回答4:

To make the "ceiling" function correctly (VBA / excel 2007) the "precise" statement is not required.
Macro is working correctly with:

lngRowSize = WorksheetFunction.Ceiling(.bmfi.intBits * .bmfi.lngWidth / 32, 0.5) * 4