www.pudn.com > Txt-To-Image.rar > SaveBitmap.bas, change:2010-04-28,size:3869b


Attribute VB_Name = "SaveBitmap" 
Option Explicit 
 
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long 
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long 
 
Private 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 
 
Public Function SaveBitmapAsToFile(hBitmap As Long, FileName As String) As Boolean 
    Dim FileNum As Long 
    FileNum = FreeFile 
    Open FileName For Binary As FileNum 
    If Dir$(FileName) <> "" Then 
        Dim OneByte As Byte, TwoByte As Integer, FourByte As Long 
        Dim bm As Bitmap 
        Call GetObject(hBitmap, LenB(bm), bm) 
        '保存文件头 
        Const BI_RGB As Long = 0& 
        Put FileNum, , "BM"              'filetype 
        FourByte = bm.bmHeight * (bm.bmWidth * 3 + 4 - (bm.bmWidth * 3) Mod 4) + 54 
        Put FileNum, , FourByte                     'filelen 
        TwoByte = 0 
        Put FileNum, , TwoByte                      '保留字段 
        Put FileNum, , TwoByte                      '保留字段 
        FourByte = 14 + 40 
        Put FileNum, , FourByte                     '颜色数据的起始位置 
        FourByte = 40 
        Put FileNum, , FourByte                     '图的头信息长度 
        FourByte = bm.bmWidth 
        Put FileNum, , FourByte                      '图的宽度 
        FourByte = bm.bmHeight 
        Put FileNum, , FourByte                     '图的高度 
        TwoByte = 1 
        Put FileNum, , TwoByte                      '必须是1,不用考虑 
        TwoByte = 24 
        Put FileNum, , TwoByte                      '指定表示颜色时要用到的位数 
        FourByte = BI_RGB 
        Put FileNum, , FourByte                     '指定位图是否压缩,0表示未压缩 
        FourByte = bm.bmHeight * (bm.bmWidth * 3 + 4 - (bm.bmWidth * 3) Mod 4) 
        Put FileNum, , FourByte                     '位图数据所占的字节数 
        FourByte = 300 
        Put FileNum, , FourByte                     '指定目标设备的水平分辨率,单位是每米的象素个数 
        Put FileNum, , FourByte                     '指定目标设备的垂直分辨率 
        FourByte = 0 
        Put FileNum, , FourByte                     '指定本图象实际用到的颜色数 
        Put FileNum, , FourByte                     '指定本图象中重要的颜色数,如果该值为零,则认为所有的颜色都是重要的 
        '保存位图数据 
        Dim y As Long, x As Long, ColorValue As Long, R As Long, G As Long, B As Long, i As Long, t As Long 
        Dim byteData() As Byte 
        Dim BitData() As Byte 
        ReDim byteData(bm.bmWidth * bm.bmHeight * 4 - 1) 
        FourByte = bm.bmHeight * (bm.bmWidth * 3 + 4 - (bm.bmWidth * 3) Mod 4) 
        ReDim BitData(FourByte) 
        GetBitmapBits hBitmap, bm.bmWidth * bm.bmHeight * 4, byteData(0) 
        t = 0 
        For y = bm.bmHeight - 1 To 0 Step -1 
            For x = 0 To bm.bmWidth - 1 
                BitData(t) = byteData((y * bm.bmWidth + x) * 4) 
                t = t + 1 
                BitData(t) = byteData((y * bm.bmWidth + x) * 4 + 1) 
                t = t + 1 
                BitData(t) = byteData((y * bm.bmWidth + x) * 4 + 2) 
                t = t + 1 
            Next x 
            If (bm.bmWidth * 3) Mod 4 <> 0 Then 
                For i = 0 To (4 - (bm.bmWidth * 3) Mod 4) - 1   '为了使每行数据所占的字节数为4的整数倍 
                    BitData(t) = 0 
                    t = t + 1 
                Next i 
            End If 
        Next y 
        Put 1, , BitData 
    Else 
        SaveBitmapAsToFile = False 
        Exit Function 
    End If 
    Close FileNum 
    SaveBitmapAsToFile = True 
End Function