★ 已知hDC，保存BMP的方法

Question

帮ThirdApple写的，顺便拿出来共享
Private Declare Function GetDIBits Lib "gdi32" (ByVal hDC As Long, ByVal hBitMap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFOHEADER, ByVal wUsage As Long) As Long
Private Const DIB_RGB_COLORS = 0
Private Type BITMAPFILEHEADER
        bfType(0 To 1) As Byte
        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 TypePrivate Declare Function GetCurrentObject Lib "gdi32" (ByVal hDC As Long, ByVal uObjectType As Long) As Long
Private Const OBJ_BITMAP = 7Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Type BITMAP
        bmType As Long
        bmWidth As Long
        bmHeight As Long
        bmWidthBytes As Long
        bmPlanes As Integer
        bmBitsPixel As Integer
        bmBits As Long
End TypePublic Function SaveBMP(ByVal hDC As Long, FileName As String) As Boolean
    Dim hBitMap As Long
    hBitMap = GetCurrentObject(hDC, OBJ_BITMAP) '取得位图
    If hBitMap = 0 Then Exit Function
    
    Dim bm As BITMAP
    If GetObject(hBitMap, Len(bm), bm) = 0 Then Exit Function '得到位图信息
    
    Dim bmih As BITMAPINFOHEADER
    bmih.biSize = Len(bmih)
    bmih.biWidth = bm.bmWidth
    bmih.biHeight = bm.bmHeight
    bmih.biBitCount = 24
    bmih.biPlanes = 1
    bmih.biSizeImage = ((bmih.biWidth * 3 + 3) And &H7FFFFFFC) * bmih.biHeight '计算大小
    
    ReDim MapData(1 To bmih.biSizeImage) As Byte
    If GetDIBits(hDC, hBitMap, 0, bmih.biHeight, MapData(1), bmih, DIB_RGB_COLORS) = 0 Then Exit Function '取得位图数据
    
    Dim hF As Integer
    hF = FreeFile(1)
    
    On Error Resume Next
    Open FileName For Binary As hF
    If Err.Number Then hF = -1
    On Error GoTo 0
    If hF = -1 Then Exit Function
    
    Dim bmfh As BITMAPFILEHEADER
    bmfh.bfType(0) = Asc("B")
    bmfh.bfType(1) = Asc("M")
    bmfh.bfOffBits = Len(bmfh) + Len(bmih)
    Put hF, , bmfh
    
    Put hF, , bmih
    
    Put hF, , MapData
    
    Close hF
    
    SaveBMP = True
    
End Function
Private Sub Picture1_Click()
    SaveBMP Picture1.hDC, "c:\Debug.bmp"
    
End Sub

Answer 1

收藏的，也贴出来共享一下，zyl910 (910：分儿，我来了！)，你不会有意见吧
已知hDC，把图象保存为256色、16色、2色、256级灰度bmp图象的方法
模块：
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 2

续上：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 3

觉得楼主的标题应该是"如何不用vb的方法保存位图"
因为如果标题是"已知hDC，保存BMP的方法"
显然还有另外一种方法处理,
就是,用bitblt画到picturebox上,然后用vb的savepicture

Answer 4

而, rainstormmaster(rainstormmaster)的收藏显然更有意思些

Answer 5

TO lingll
其实我觉得rainstormmaster的代码没有zyl910的好，zyl910的代码看起来更简洁，而且要支持更多的颜色位数也至少改改一点地方就可以了

Answer 6

to thirdapple
其实我没有认真看rainstormmaster的代码,
但是看标题"已知hDC，把图象保存为256色、16色、2色、256级灰度bmp图象的方法"(暂称r标题)
就比"已知hDC，保存BMP的方法"(暂称z标题)有意思多了
显然,一看r标题就知道这种做法不能通过vb方式保存,于是有看头
而,z标题却可以通过vb方式保存上面所指的保存是"写入文件",不包括前面所做的事情

Answer 7

lingll(20分) ,相信savepicture这样肤浅的方法
搂主,apple等人早就知道了这里是讨论问题的地方,不是吹毛求疵的地方,呵呵你要是有高深的程序,欢迎贴出来,大家共赏
你尽可以起你喜欢的标题,我们不会有任何异议

Answer 8

我这是根据BMP的文件格式写的