www.pudn.com > imagescale---raw.zip > ClsDIB.cls

VERSION 1.0 CLASS 
BEGIN 
  MultiUse = -1  'True 
  Persistable = 0  'NotPersistable 
  DataBindingBehavior = 0  'vbNone 
  DataSourceBehavior  = 0  'vbNone 
  MTSTransactionMode  = 0  'NotAnMTSObject 
END 
Attribute VB_Name = "ClsDIB" 
Attribute VB_GlobalNameSpace = False 
Attribute VB_Creatable = True 
Attribute VB_PredeclaredId = False 
Attribute VB_Exposed = False 
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes" 
Attribute VB_Ext_KEY = "Top_Level" ,"Yes" 
Option Explicit 
 
Private MyhDC As Long 
Private MyBMI As BitMapInfo 
Private MyhDIB As Long 
Private MyPtr As Long 
Private m_WidthBytes As Long 
Private hOldMap As Long 
 
Private Sub Class_Initialize() 
    MyhDC = 0 
     
End Sub 
 
Private Sub Class_Terminate() 
    Free 
End Sub 
 
Public Property Get hDC() As Long 
    hDC = MyhDC 
End Property 
 
Public Property Get DataSize() As Long 
    DataSize = MyBMI.bmiHeader.biSizeImage 
End Property 
 
Public Property Get Width() As Long 
    Width = MyBMI.bmiHeader.biWidth 
End Property 
 
Public Property Get Height() As Long 
    Height = MyBMI.bmiHeader.biHeight 
End Property 
 
Public Property Get WidthBytes() As Long 
    WidthBytes = m_WidthBytes 
End Property 
 
Public Property Get ColorBit() As Long 
    ColorBit = MyBMI.bmiHeader.biBitCount 
End Property 
 
Public Property Get DataPtr() As Long 
    DataPtr = MyPtr 
End Property 
 
'创建图片 
Public Function Create(ByVal Width As Long, ByVal Height As Long, _ 
        Optional ByVal CBit As Long = 32, _ 
        Optional ClsMap As Boolean = True) As Boolean 
    If Width <= 0 Or Height <= 0 Then 
        Create = False 
        Exit Function 
    End If 
     
    Select Case CBit 
    Case 1, 4, 8, 16, 24, 32 
    Case Else 
        Create = False 
        Exit Function 
    End Select 
     
    Free 
     
    With MyBMI.bmiHeader 
        .biSize = Len(MyBMI.bmiHeader) 
        .biWidth = Width 
        .biHeight = Height 
        .biPlanes = 1 
        .biBitCount = CBit 
        .biCompression = BI_RGB 
        m_WidthBytes = GetWidthBytes(.biWidth, .biBitCount) 
        m_WidthBytes = (m_WidthBytes + 3) And &H7FFFFFFC 
        .biSizeImage = m_WidthBytes * .biHeight 
         
    End With 
    MyhDC = CreateCompatibleDC(0) 
    MyhDIB = CreateDIBSection(MyhDC, MyBMI, IIf(CBit > 8, DIB_RGB_COLORS, DIB_PAL_COLORS), MyPtr, 0, 0) 
    If MyhDIB Then 
        hOldMap = SelectObject(MyhDC, MyhDIB) 
        If ClsMap Then Cls ': SetRectAlpha &HFF 
        Create = True 
    End If 
     
End Function 
 
'释放图片 
Public Sub Free() 
    If Me.DataPtr Then 
        If hOldMap Then DeleteObject SelectObject(MyhDC, hOldMap) 
        hOldMap = 0 
        DeleteDC MyhDC 
        MyhDC = 0 
        MyBMI.bmiHeader.biBitCount = 0 
        MyBMI.bmiHeader.biWidth = 0 
        MyBMI.bmiHeader.biHeight = 0 
        MyBMI.bmiHeader.biSizeImage = 0 
        MyhDIB = 0 
        MyPtr = 0 
         
    End If 
     
End Sub 
 
'初始化图片 
Public Sub Cls() 
    If Me.DataPtr Then ZeroMemory ByVal MyPtr, MyBMI.bmiHeader.biSizeImage 
End Sub 
 
 
Public Function PutTo(ByVal hDestDC As Long, _ 
        Optional ByVal X As Long = 0, Optional ByVal Y As Long = 0, _ 
        Optional ByVal nWidth As Long = CW_USEDEFAULT, _ 
        Optional ByVal nHeight As Long = CW_USEDEFAULT, _ 
        Optional ByVal xSrc As Long = 0, Optional ByVal ySrc As Long = 0) As Boolean 
    If Me.DataPtr = 0 Then Exit Function 
    If nWidth = CW_USEDEFAULT Then nWidth = Me.Width 
    If nHeight = CW_USEDEFAULT Then nHeight = Me.Height 
     
    PutTo = SetDIBitsToDevice(hDestDC, X, Y, Width, Height, _ 
            xSrc, ySrc, _ 
            0, Me.Height, _ 
            ByVal Me.DataPtr, MyBMI, _ 
            IIf(Me.ColorBit > 8, DIB_RGB_COLORS, DIB_PAL_COLORS)) 
     
End Function 
 
Public Function PutToEx(ByVal hDestDC As Long, _ 
        Optional ByVal X As Long = 0, Optional ByVal Y As Long = 0, _ 
        Optional ByVal nWidth As Long = CW_USEDEFAULT, _ 
        Optional ByVal nHeight As Long = CW_USEDEFAULT, _ 
        Optional ByVal xSrc As Long = 0, Optional ByVal ySrc As Long = 0, _ 
        Optional ByVal nSrcWidth As Long = CW_USEDEFAULT, _ 
        Optional ByVal nSrcHeight As Long = CW_USEDEFAULT, _ 
        Optional ByVal dwRop As RasterOpConstants = vbSrcCopy) As Boolean 
    If Me.DataPtr = 0 Then Exit Function 
    If nWidth = CW_USEDEFAULT Then nWidth = Me.Width 
    If nHeight = CW_USEDEFAULT Then nHeight = Me.Height 
    If nSrcWidth = CW_USEDEFAULT Then nSrcWidth = Me.Width 
    If nSrcHeight = CW_USEDEFAULT Then nSrcHeight = Me.Height 
     
    PutToEx = StretchDIBits(hDestDC, X, Y, nWidth, nHeight, _ 
            xSrc, ySrc, nSrcWidth, nSrcHeight, _ 
            ByVal Me.DataPtr, MyBMI, _ 
            IIf(Me.ColorBit > 8, DIB_RGB_COLORS, DIB_PAL_COLORS), _ 
            dwRop) 
     
End Function 
 
 
Private Function ChkFileWrite(FileName As String) As Boolean 
    Dim FileNum As Integer 
     
    FileNum = FreeFile 
     
    On Error Resume Next 
     
    Open FileName For Output As #FileNum 
     
    If Err.Number Then 
        ' 
    Else 
        Close #FileNum 
        ChkFileWrite = True 
    End If 
     
    On Error GoTo 0 
     
End Function 
 
Public Function SaveBMP(FileName As String) As Boolean 
    Dim FileNum As Integer 
    Dim TempBMFH As BITMAPFILEHEADER 
    Dim TCB() As RGBQuad 
    Dim TempBytes() As Byte 
     
    If (ChkFileWrite(FileName) = False) Or (MyPtr = 0) Then Exit Function 
     
    TempBMFH.bfType(1) = Asc("B") 
    TempBMFH.bfType(2) = Asc("M") 
    TempBMFH.bfOffBits = Len(TempBMFH) + Len(MyBMI.bmiHeader) 
    If MyBMI.bmiHeader.biBitCount <= 8 Then 
        TempBMFH.bfOffBits = TempBMFH.bfOffBits + 4 * 2 ^ MyBMI.bmiHeader.biBitCount 
         
        ReDim TCB(1 To 2 ^ MyBMI.bmiHeader.biBitCount) 
        GetDIBColorTable MyhDC, 0, 2 ^ MyBMI.bmiHeader.biBitCount, TCB(1) 
         
    End If 
     
    TempBMFH.bfSize = TempBMFH.bfOffBits + MyBMI.bmiHeader.biSizeImage 
     
    ReDim TempBytes(1 To MyBMI.bmiHeader.biSizeImage) 
    CopyMemory TempBytes(1), ByVal MyPtr, MyBMI.bmiHeader.biSizeImage 
     
    FileNum = FreeFile 
     
    Open FileName For Binary As #FileNum 
     
    Put #FileNum, , TempBMFH 
    Put #FileNum, , MyBMI.bmiHeader 
    If MyBMI.bmiHeader.biBitCount <= 8 Then Put #FileNum, , TCB 
    Put #FileNum, , TempBytes 
     
    Close #FileNum 
     
    SaveBMP = True 
     
End Function