★ 已知hDC，保存BMP的方法

[zyl910]

帮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 Type

Private Declare Function GetCurrentObject Lib "gdi32" (ByVal hDC As Long, ByVal uObjectType As Long) As Long
Private Const OBJ_BITMAP = 7

Private 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 Type

Public 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

[dsclub]

先占个座位

[thirdapple]

Up

[painache]

mark & up

[IMHELLFIRE]

顶！

[rainstormmaster]

收藏的，也贴出来共享一下，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 Type

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

Type 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 Type

Type 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 Type

Const 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 Long

Public 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 Function

Public 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

[rainstormmaster]

续上：

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 Function

Public 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 Explicit

Private Sub Command1_click()
Command1.Enabled = False
Call SaveBMP256(pic, App.Path & "\256.bmp")
Picture1.Picture = LoadPicture(App.Path & "\256.bmp")
Command1.Enabled = True
End Sub

Private 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 Sub

Private Sub Command4_Click()
Command4.Enabled = False
Call SaveBMP16(pic, App.Path & "\x16.bmp")
Picture1.Picture = LoadPicture(App.Path & "\x16.bmp")
Command4.Enabled = True
End Sub

Private 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

[lingll]

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

上面所指的保存是"写入文件",不包括前面所做的事情

[cnhgj]

up

[射天狼]

收藏

[张志龙]

收了先。

[nik_Amis]

lingll(20分) ,相信savepicture这样肤浅的方法
搂主,apple等人早就知道了

这里是讨论问题的地方,不是吹毛求疵的地方,呵呵

你要是有高深的程序,欢迎贴出来,大家共赏
你尽可以起你喜欢的标题,我们不会有任何异议

[永远专注NET]

up

[nik_Amis]

up

[lingll]

只是提个建议,用不着这样

[rainstormmaster]

呵呵

[zyl910]

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

[lingll]

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

[lingll]

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

[thirdapple]

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

[guxing]

收藏，谢谢！！！