如何将DC或者PictureBox中的图片保存成256色格式的BMP

Question

在不改变系统设置的前提下，
如何保存256色的BMP图片呢
我SavePicture总是24位色的。

Answer 1

savepicture当然是24BIT的了。还是自己写BITMAP吧……

Answer 2

不会吧，自己写啊？
用VB写会好慢啊。
我把PictureBox的Palette设置成256色可以有什么用吗？

Answer 3

用api写不会很慢的呀,呵呵.
-----------------------------------------
目前正在做一个桌面日历程序,学习中.....

Answer 4

http://expert.csdn.net/Expert/topic/1538/1538596.xml?temp=3.922671E-02

Answer 5

ZYL910班主写过一个抖动算法,可以把24位BMP转换为2,256,网页色,16位...自己找找吧,应该可以找到...

Answer 6

boyzhang(张郎) 
能不能帮找一下？

Answer 7

Option Explicit
Type BitmapFileHeader
    bfType      As String * 2
    bfSize      As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits   As Long
End TypeType 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 TypeType BitMapInfo256
     bmiHeader As BitmapInfoHeader
     bmiColors(0 To 255) As Long
End Type
Type BitMapInfo16
     bmiHeader As BitmapInfoHeader
     bmiColors(0 To 15) As Long
End Type
Type BitMapInfo2
     bmiHeader As BitmapInfoHeader
     bmiColors(0 To 1) As Long
End TypeType Bitmap '14 bytes
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End TypeConst DIB_RGB_COLORS = 0&
Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Declare Function GetDIBits256 Lib "gdi32" Alias "GetDIBits" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BitMapInfo256, ByVal wUsage As Long) As Long
Declare Function GetDIBits16 Lib "gdi32" Alias "GetDIBits" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BitMapInfo16, ByVal wUsage As Long) As Long
Declare Function GetDIBits2 Lib "gdi32" Alias "GetDIBits" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BitMapInfo2, ByVal wUsage As Long) As Long
Declare Function CreateDIBSection256 Lib "gdi32" Alias "CreateDIBSection" (ByVal hDC As Long, pBitmapInfo As BitMapInfo256, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Declare Function CreateDIBSection16 Lib "gdi32" Alias "CreateDIBSection" (ByVal hDC As Long, pBitmapInfo As BitMapInfo16, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Declare Function CreateDIBSection2 Lib "gdi32" Alias "CreateDIBSection" (ByVal hDC As Long, pBitmapInfo As BitMapInfo2, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As LongPublic Function SaveBMP256(pic As PictureBox, FilePathName$) As Long
Dim bm As Bitmap, SizeOfArray As Long, fp As Long
Dim bf As BitmapFileHeader, bi As BitMapInfo256, buffer() As Byte
Dim hDC As Long, hDIB As Long, OldObj As Long
Dim i As Long, r As Integer, g As Integer, b As Integer
    '
    Call GetObject(pic.Picture, Len(bm), bm)
    SizeOfArray = (((bm.bmWidth + 3) \ 4) * 4) * bm.bmHeight
       With bf
        .bfType = "BM"
        .bfSize = Len(bf) + Len(bi) + SizeOfArray
        .bfReserved1 = 0
        .bfReserved2 = 0
        .bfOffBits = Len(bf) + Len(bi)
    End With
    With bi
        With .bmiHeader
        .biSize = Len(bi.bmiHeader)
        .biWidth = bm.bmWidth
        .biHeight = bm.bmHeight
        .biPlanes = 1
        .biBitCount = 8
        .biCompression = 0
        .biSizeImage = SizeOfArray
        End With
        i = 0
        For b = 0 To &HE0 Step &H20
            For g = 0 To &HE0 Step &H20
                For r = 0 To &HC0 Step &H40
                    bi.bmiColors(i) = IIf(b = &HE0, &HFF, b) * &H10000 + IIf(g = &HE0, &HFF, g) * &H100 + IIf(r = &HC0, &HFF, r)
                    i = i + 1
                Next r
            Next g
        Next b
    End With
    ReDim buffer(0 To bi.bmiHeader.biSizeImage - 1) As Byte
    hDC = CreateCompatibleDC(0&)
    hDIB = CreateDIBSection256(hDC, bi, DIB_RGB_COLORS, i, 0&, 0&)
    OldObj = SelectObject(hDC, hDIB)
    Call BitBlt(hDC, 0&, 0&, bm.bmWidth, bm.bmHeight, pic.hDC, 0&, 0&, vbSrcCopy)
    Call GetDIBits256(hDC, hDIB, 0, (bm.bmHeight), buffer(0), bi, 0)
    SelectObject hDC, OldObj
    DeleteDC hDC
    DeleteObject hDIB
    '
    On Error Resume Next
    Kill FilePathName
    Err.Number = 0
    fp = FreeFile()
    Open FilePathName For Binary As #fp
    If Err.Number <> 0 Then
        SaveBMP256 = Err.Number
        Exit Function
    End If
   
    Put #fp, 1, bf
    Put #fp, , bi
    Put #fp, , buffer
    Close #fp
End FunctionPublic Function SaveBMP16(pic As PictureBox, FilePathName$) As Long
Dim bm As Bitmap, SizeOfArray As Long, fp As Long
Dim bf As BitmapFileHeader, bi As BitMapInfo16, buffer() As Byte
Dim hDC As Long, hDIB As Long, OldObj As Long
Dim i As Long, r As Integer, g As Integer, b As Integer
    '
    Call GetObject(pic.Picture, Len(bm), bm)
    SizeOfArray = (((bm.bmWidth / 2 + 3) \ 4) * 4) * bm.bmHeight
    '
    With bf
        .bfType = "BM"
        .bfSize = Len(bf) + Len(bi) + SizeOfArray
        .bfReserved1 = 0
        .bfReserved2 = 0
        .bfOffBits = Len(bf) + Len(bi)
    End With
    With bi
        With .bmiHeader
        .biSize = Len(bi.bmiHeader)
        .biWidth = bm.bmWidth
        .biHeight = bm.bmHeight
        .biPlanes = 1
        .biBitCount = 4
        .biCompression = 0
        .biSizeImage = SizeOfArray
        End With
        For i = 0 To 15
            .bmiColors(i) = QBColor(i)
        Next i
    End With
    ReDim buffer(bi.bmiHeader.biSizeImage - 1) As Byte
    hDC = CreateCompatibleDC(0&)
    hDIB = CreateDIBSection16(hDC, bi, DIB_RGB_COLORS, i, 0&, 0&)
    OldObj = SelectObject(hDC, hDIB)
    Call BitBlt(hDC, 0&, 0&, bm.bmWidth, bm.bmHeight, pic.hDC, 0&, 0&, vbSrcCopy)
    Call GetDIBits16(hDC, hDIB, 0, (bm.bmHeight), buffer(0), bi, 0)
    SelectObject hDC, OldObj
    DeleteDC hDC
    DeleteObject hDIB
    On Error Resume Next
    Kill FilePathName
    Err.Number = 0
    fp = FreeFile()
    Open FilePathName For Binary As #fp
    If Err.Number <> 0 Then
        SaveBMP16 = Err.Number
        Exit Function
    End If
    Put #fp, 1, bf
    Put #fp, , bi
    Put #fp, , buffer
    Close #fp
End Function

Answer 8

续上：Public Function SaveBMP2(pic As PictureBox, FilePathName$) As Long
Dim bm As Bitmap, SizeOfArray As Long, fp As Long
Dim bf As BitmapFileHeader, bi As BitMapInfo2, buffer() As Byte
Dim hDC As Long, hDIB As Long, OldObj As Long
Dim i As Long, r As Integer, g As Integer, b As Integer
    '
    Call GetObject(pic.Picture, Len(bm), bm)
    SizeOfArray = (((bm.bmWidth / 8 + 3) \ 4) * 4) * bm.bmHeight
    '
    With bf
        .bfType = "BM"
        .bfSize = Len(bf) + Len(bi) + SizeOfArray
        .bfReserved1 = 0
        .bfReserved2 = 0
        .bfOffBits = Len(bf) + Len(bi)
    End With
    With bi
        With .bmiHeader
        .biSize = Len(bi.bmiHeader)
        .biWidth = bm.bmWidth
        .biHeight = bm.bmHeight
        .biPlanes = 1
        .biBitCount = 1
        .biCompression = 0
        .biSizeImage = SizeOfArray
        End With
            .bmiColors(0) = vbWhite
            .bmiColors(1) = vbBlack
    End With
    ReDim buffer(bi.bmiHeader.biSizeImage - 1) As Byte
    hDC = CreateCompatibleDC(0&)
    hDIB = CreateDIBSection2(hDC, bi, DIB_RGB_COLORS, i, 0&, 0&)
    OldObj = SelectObject(hDC, hDIB)
    Call BitBlt(hDC, 0&, 0&, bm.bmWidth, bm.bmHeight, pic.hDC, 0&, 0&, vbSrcCopy)
    Call GetDIBits2(hDC, hDIB, 0, (bm.bmHeight), buffer(0), bi, 0)
    SelectObject hDC, OldObj
    DeleteDC hDC
    DeleteObject hDIB
    '
    On Error Resume Next
    Kill FilePathName
    Err.Number = 0
    fp = FreeFile()
    Open FilePathName For Binary As #fp
    If Err.Number <> 0 Then
        SaveBMP2 = Err.Number
        Exit Function
    End If
    Put #fp, 1, bf
    Put #fp, , bi
    Put #fp, , buffer
    Close #fp
End FunctionPublic Function SaveBMP256B(pic As PictureBox, FilePathName$) As Long
Dim bm As Bitmap, SizeOfArray As Long, fp As Long
Dim bf As BitmapFileHeader, bi As BitMapInfo256, buffer() As Byte
Dim hDC As Long, hDIB As Long, OldObj As Long
Dim i As Long, r As Integer, g As Integer, b As Integer
    '
    Call GetObject(pic.Picture, Len(bm), bm)
    SizeOfArray = (((bm.bmWidth + 3) \ 4) * 4) * bm.bmHeight
    
    With bf
        .bfType = "BM"
        .bfSize = Len(bf) + Len(bi) + SizeOfArray
        .bfReserved1 = 0
        .bfReserved2 = 0
        .bfOffBits = Len(bf) + Len(bi)
    End With
    With bi
        With .bmiHeader
        .biSize = Len(bi.bmiHeader)
        .biWidth = bm.bmWidth
        .biHeight = bm.bmHeight
        .biPlanes = 1
        .biBitCount = 8
        .biCompression = 0
        .biSizeImage = SizeOfArray
        End With
        i = 0
        For i = 0 To 255
                    bi.bmiColors(i) = i * &H10000 + i * &H100 + i
        Next i
    End With
    
    ReDim buffer(0 To bi.bmiHeader.biSizeImage - 1) As Byte
    hDC = CreateCompatibleDC(0&)
    hDIB = CreateDIBSection256(hDC, bi, DIB_RGB_COLORS, i, 0&, 0&)
    OldObj = SelectObject(hDC, hDIB)
    Call BitBlt(hDC, 0&, 0&, bm.bmWidth, bm.bmHeight, pic.hDC, 0&, 0&, vbSrcCopy)
    Call GetDIBits256(hDC, hDIB, 0, (bm.bmHeight), buffer(0), bi, 0)
    SelectObject hDC, OldObj
    DeleteDC hDC
    DeleteObject hDIB
    On Error Resume Next
    Kill FilePathName
    Err.Number = 0
    fp = FreeFile()
    Open FilePathName For Binary As #fp
    If Err.Number <> 0 Then
        SaveBMP256B = Err.Number
        Exit Function
    End If
    Put #fp, 1, bf
    Put #fp, , bi
    Put #fp, , buffer
    Close #fp
End Function
窗体：2个picturebox，5个按钮
Option ExplicitPrivate Sub Command1_click()
    Command1.Enabled = False
    Call SaveBMP256(pic, App.Path & "\256.bmp")
    Picture1.Picture = LoadPicture(App.Path & "\256.bmp")
    Command1.Enabled = True
End SubPrivate Sub Command2_Click()
    SavePicture pic.Picture, App.Path & "\VBDefault.bmp"
    Picture1.Picture = LoadPicture(App.Path & "\VBDefault.bmp")
End Sub
Private Sub Command3_Click()
    Command3.Enabled = False
    Call SaveBMP2(pic, App.Path & "\x2.bmp")
    Picture1.Picture = LoadPicture(App.Path & "\x2.bmp")
    Command3.Enabled = True
End SubPrivate Sub Command4_Click()
    Command4.Enabled = False
    Call SaveBMP16(pic, App.Path & "\x16.bmp")
    Picture1.Picture = LoadPicture(App.Path & "\x16.bmp")
    Command4.Enabled = True
End SubPrivate Sub Command5_Click()
    Command5.Enabled = False
    Call SaveBMP256B(pic, App.Path & "\256b.bmp")
    Picture1.Picture = LoadPicture(App.Path & "\256b.bmp")
    Command5.Enabled = True
End Sub
做一会搬运工！

Answer 9

另外，可以参看
http://expert.csdn.net/Expert/topic/1538/1538596.xml?temp=.8451349
根据BMP文件格式保存BMP