由VBA Creatig 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