我试图创建一个将单元格的值转换为 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
输出与我的预期有很大不同(左 - 实际输出,右 - 预期输出)。
最佳答案
代码中有一个小错误。
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
关于vba - 使用 VBA 创建 BMP 图像,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/28353355/