求解，VB二进制方式写24位BMP图片的那点事。

Question

小弟最近研究BMP的读写问题。
读目前已经解决了，但是写的话有一点问题。特来请教各位前辈。
下面是我目前的代码。Private Type BITMAPFILEHEADER
    bfType   As Integer
    bfSize   As Long
    bfReserved1   As Integer
    bfReserved2   As Integer
    bfOffBits 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
    biSizeImage   As Long
    biXPelsPerMeter   As Long
    biYPelsPerMeter   As Long
    biClrUsed   As Long
    biClrImportant   As Long
End Type
Private Type BmpPix
    B As Byte
    G As Byte
    R As Byte
End Type
Private Sub Command1_Click()
Dim data() As Variant
data = GetBmp("c:\2.bmp", 0)
SetBMP "c:\1.bmp", data, 0
End Sub
Function SetBMP(filename As Variant, data As Variant, mose As Variant) As Variant
Dim BmpData As BmpPix
Dim BmpOne As BITMAPFILEHEADER
Dim BmpTow As BITMAPINFOHEADER
Dim i As Long, o As Long, Tmp As Variant, u As Long, out As Byte
out = 0
BmpTow.biSize = 40
BmpTow.biWidth = UBound(data, 1) + 1
BmpTow.biHeight = UBound(data, 2) + 1
BmpTow.biPlanes = 1
BmpTow.biBitCount = 24
BmpTow.biCompression = 0
BmpTow.biSizeImage = 0
BmpTow.biXPelsPerMeter = 0
BmpTow.biYPelsPerMeter = 0
BmpTow.biClrUsed = 0
BmpTow.biClrImportant = 0
i = BmpTow.biWidth * 3
While i Mod 4 <> 0
    i = i + 1
    u = u + 1
Wend
BmpOne.bfType = &H4D42
BmpOne.bfReserved1 = 0
BmpOne.bfReserved2 = 0
BmpOne.bfOffBits = LenB(BmpOne) + LenB(BmpTow)
BmpOne.bfSize = i * BmpTow.biHeight + BmpOne.bfOffBits
Open filename For Binary As #1
Put #1, , BmpOne
Put #1, , BmpTow
For o = UBound(data, 2) To 0 Step -1
    For i = 0 To UBound(data, 1)
        Tmp = data(i, o)
        If mose = 0 Then
            BmpData.R = CLng("&H" + Mid(Tmp, 1, 2))
            BmpData.G = CLng("&H" + Mid(Tmp, 3, 2))
            BmpData.B = CLng("&H" + Mid(Tmp, 5, 2))
        Else
            BmpData.B = CLng("&H" + Mid(Tmp, 1, 2))
            BmpData.G = CLng("&H" + Mid(Tmp, 3, 2))
            BmpData.R = CLng("&H" + Mid(Tmp, 5, 2))
        End If
        Put #1, , BmpData
    Next
    For i = 1 To u
        Put #1, , out
    Next
Next
Close #1
End FunctionPublic Function GetBmp(file As Variant, mose As Variant) As Variant
Dim BMPWidth As Long
Dim BMPHeight As Long
Dim LineWidth As Long
Dim ArrByte(0 To 2) As Byte
Dim i As Long
Dim o As Long
Dim temp As String
Dim tempR As String
Dim tempG As String
Dim tempB As String
Open file For Binary As #1
Get #1, 19, BMPWidth
Get #1, 23, BMPHeight
ReDim rgb_s(0 To BMPWidth - 1, 0 To BMPHeight - 1) As Variant
Select Case (BMPWidth * 3) Mod 4
Case 0
LineWidth = BMPWidth * 3
Case 1
LineWidth = BMPWidth * 3 + 3
Case 2
LineWidth = BMPWidth * 3 + 2
Case 3
LineWidth = BMPWidth * 3 + 1
End Select
For i = 0 To BMPWidth - 1
For o = 0 To BMPHeight - 1
Get #1, FindByte(LineWidth, BMPHeight, i, o), ArrByte
tempR = Hex(ArrByte(2)): tempG = Hex(ArrByte(1)): tempB = Hex(ArrByte(0))
If Len(tempR) = 1 Then tempR = "0" + tempR
If Len(tempG) = 1 Then tempG = "0" + tempG
If Len(tempB) = 1 Then tempB = "0" + tempB
If mose = 0 Then
    rgb_s(i, o) = tempR + tempG + tempB
ElseIf mose = 1 Then
    rgb_s(i, o) = tempB + tempG + tempR
End If
Next
Next
Close #1
GetBmp = rgb_s
End FunctionPrivate Function FindByte(ByVal LineWidth As Long, ByVal LineCount As Long, ByVal x As Long, ByVal y As Long) As Long
FindByte = (55 + (LineCount - y - 1) * LineWidth + 3 * x)
End Function
以上代码读出来的图像会有颜色错误，以及图像扭曲等问题。
请各位前辈指正

Answer 1

Private Type BITMAPFILEHEADER
    bfType   As Integer
    bfSize   As Long
    bfReserved1   As Integer
    bfReserved2   As Integer
    bfOffBits 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
    biSizeImage   As Long
    biXPelsPerMeter   As Long
    biYPelsPerMeter   As Long
    biClrUsed   As Long
    biClrImportant   As Long
End Type
Private Type BmpPix
    B As Byte
    G As Byte
    R As Byte
End TypeDim 文件长度 As Long
Dim 文件长度码 As StringPrivate Sub Command1_Click()
Dim data() As Variant
data = GetBmp(App.Path & "\2.bmp", 0)
SetBMP App.Path & "\1.bmp", data, 0
End Sub
Function SetBMP(filename As Variant, data As Variant, mose As Variant) As Variant
Dim BmpData As BmpPix
Dim BmpOne As BITMAPFILEHEADER
Dim BmpTow As BITMAPINFOHEADER
Dim i As Long, o As Long, Tmp As Variant, u As Long, out As Byte
out = 0BmpTow.biSize = 40
BmpTow.biWidth = UBound(data, 1) + 1
BmpTow.biHeight = UBound(data, 2) + 1
BmpTow.biPlanes = 1
BmpTow.biBitCount = 24
BmpTow.biCompression = 0
BmpTow.biSizeImage = 文件长度码
BmpTow.biXPelsPerMeter = 0
BmpTow.biYPelsPerMeter = 0
BmpTow.biClrUsed = 0
BmpTow.biClrImportant = 0
i = BmpTow.biWidth * 3
While i Mod 4 <> 0
    i = i + 1
    u = u + 1
Wend
BmpOne.bfType = &H4D42
BmpOne.bfReserved1 = 0
BmpOne.bfReserved2 = 0
BmpOne.bfOffBits = LenB(BmpOne) + LenB(BmpTow) - 2
BmpOne.bfSize = i * BmpTow.biHeight + BmpOne.bfOffBits - 2
Open filename For Binary As #1
Put #1, , BmpOne
Put #1, , BmpTow
For o = UBound(data, 2) To 0 Step -1
    For i = 0 To UBound(data, 1)
        Tmp = data(i, o)
        If mose = 0 Then
            BmpData.R = CLng("&H" + Mid(Tmp, 1, 2))
            BmpData.G = CLng("&H" + Mid(Tmp, 3, 2))
            BmpData.B = CLng("&H" + Mid(Tmp, 5, 2))
        Else
            BmpData.B = CLng("&H" + Mid(Tmp, 1, 2))
            BmpData.G = CLng("&H" + Mid(Tmp, 3, 2))
            BmpData.R = CLng("&H" + Mid(Tmp, 5, 2))
        End If
        Put #1, , BmpData
    Next
    For i = 1 To u
        Put #1, , out
    Next
Next
Close #1
End FunctionPublic Function GetBmp(file As Variant, mose As Variant) As Variant
Dim BMPWidth As Long
Dim BMPHeight As Long
Dim LineWidth As Long
Dim ArrByte(0 To 2) As Byte
Dim i As Long
Dim o As Long
Dim temp As String
Dim tempR As String
Dim tempG As String
Dim tempB As String
Open file For Binary As #1
文件长度 = FileLen(file)
Get #1, 19, BMPWidth
Get #1, 23, BMPHeight
ReDim rgb_s(0 To BMPWidth - 1, 0 To BMPHeight - 1) As Variant
Select Case (BMPWidth * 3) Mod 4
Case 0
LineWidth = BMPWidth * 3
Case 1
LineWidth = BMPWidth * 3 + 3
Case 2
LineWidth = BMPWidth * 3 + 2
Case 3
LineWidth = BMPWidth * 3 + 1
End Select
For i = 0 To BMPWidth - 1
For o = 0 To BMPHeight - 1
Get #1, FindByte(LineWidth, BMPHeight, i, o), ArrByte
tempR = Hex(ArrByte(2)): tempG = Hex(ArrByte(1)): tempB = Hex(ArrByte(0))
If Len(tempR) = 1 Then tempR = "0" + tempR
If Len(tempG) = 1 Then tempG = "0" + tempG
If Len(tempB) = 1 Then tempB = "0" + tempB
If mose = 0 Then
    rgb_s(i, o) = tempR + tempG + tempB
ElseIf mose = 1 Then
    rgb_s(i, o) = tempB + tempG + tempR
End If
Next
Next
Close #1
GetBmp = rgb_s
文件长度 = 文件长度 - 54Select Case Len(Hex(文件长度))
  Case 2:
  文件长度码 = IIf(Len(Hex(文件长度)) - 2 > 0, Mid(Hex(文件长度), Len(Hex(文件长度)) - 1, 2), "")
  Case 4:
  文件长度码 = IIf(Len(Hex(文件长度)) - 2 > 0, Mid(Hex(文件长度), Len(Hex(文件长度)) - 1, 2), "")
文件长度码 = 文件长度码 & IIf(Len(Hex(文件长度)) - 4 < 0, "", Mid(Hex(文件长度), Len(Hex(文件长度)) - 3, 2))
  Case 6:
  文件长度码 = IIf(Len(Hex(文件长度)) - 2 > 0, Mid(Hex(文件长度), Len(Hex(文件长度)) - 1, 2), "")
文件长度码 = 文件长度码 & IIf(Len(Hex(文件长度)) - 4 < 0, "", Mid(Hex(文件长度), Len(Hex(文件长度)) - 3, 2))
文件长度码 = 文件长度码 & IIf(Len(Hex(文件长度)) - 6 < 0, "", Mid(Hex(文件长度), Len(Hex(文件长度)) - 5, 2))
  Case 8:
  文件长度码 = IIf(Len(Hex(文件长度)) - 2 > 0, Mid(Hex(文件长度), Len(Hex(文件长度)) - 1, 2), "")
文件长度码 = 文件长度码 & IIf(Len(Hex(文件长度)) - 4 < 0, "", Mid(Hex(文件长度), Len(Hex(文件长度)) - 3, 2))
文件长度码 = 文件长度码 & IIf(Len(Hex(文件长度)) - 6 < 0, "", Mid(Hex(文件长度), Len(Hex(文件长度)) - 5, 2))
文件长度码 = 文件长度码 & IIf(Len(Hex(文件长度)) - 8 < 0, "", Mid(Hex(文件长度), Len(Hex(文件长度)) - 7, 2))
End Select
Debug.Print 文件长度码
'文件长度码 = IIf(Len(Hex(文件长度)) - 2 > 0, Mid(Hex(文件长度), Len(Hex(文件长度)) - 1, 2), "")
'文件长度码 = 文件长度码 & IIf(Len(Hex(文件长度)) - 4 < 0, "", Mid(Hex(文件长度), Len(Hex(文件长度)) - 3, 2))
'文件长度码 = 文件长度码 & IIf(Len(Hex(文件长度)) - 6 < 0, "", Mid(Hex(文件长度), Len(Hex(文件长度)) - 5, 2))
'文件长度码 = 文件长度码 & IIf(Len(Hex(文件长度)) - 8 < 0, "", Mid(Hex(文件长度), Len(Hex(文件长度)) - 7, 2))
End FunctionPrivate Function FindByte(ByVal LineWidth As Long, ByVal LineCount As Long, ByVal x As Long, ByVal y As Long) As Long
FindByte = (55 + (LineCount - y - 1) * LineWidth + 3 * x)
End Function