clsbitmap.cls

来自「复件 VB界面换肤 复件 VB界面换肤」· CLS 代码 · 共 122 行

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsBitmap"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit



Private mDC As Long         ' Memory DC
Private mBitmap As Long     ' Bitmap handle
Private mOldBitmap As Long  ' "Original" Bitmap handle

Private mWidth As Long
Private mHeight As Long


Public Function LoadFile(FileName As String) As Boolean

    ' Clear up previous DC/bitmap
    ClearAll
    
    mBitmap = LoadImage(API_NULL_HANDLE, FileName, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
    'mBitmap = FileName
    If (mBitmap <> API_NULL_HANDLE) Then
        LoadFile = LoadBitmapIntoDC
    End If
    
End Function


Public Function LoadResource(ResourceID As Long) As Boolean
    
    ' Clear up previous DC/bitmap
    ClearAll
    
    mBitmap = ResourceID 'LoadImage(App.hInstance, ResourceID, IMAGE_BITMAP, 0, 0, LR_DEFAULTCOLOR)
    
    If (mBitmap <> API_NULL_HANDLE) Then
        LoadResource = LoadBitmapIntoDC
    End If
   
End Function

Private Function LoadBitmapIntoDC() As Boolean
Dim ScreenDC As Long
Dim BitmapData As BITMAP

    ' Create a coMYPatible memory DC to hold the bitmap
    ScreenDC = GetDC(API_NULL_HANDLE)
    mDC = CreateCompatibleDC(ScreenDC)
    ReleaseDC API_NULL_HANDLE, ScreenDC
    
    If (mDC <> API_NULL_HANDLE) Then
        ' If the DC was created successfully,
        ' select the bitmap into it
        mOldBitmap = SelectObject(mDC, mBitmap)
        
        ' Get the dimensions of the bitmap
        GDIGetObject mBitmap, Len(BitmapData), BitmapData
        mWidth = BitmapData.bmWidth
        mHeight = BitmapData.bmHeight
        
        LoadBitmapIntoDC = True
    End If

End Function



Property Get Width() As Long
    Width = mWidth
End Property

Property Get Height() As Long
    Height = mHeight
End Property

Property Get hdc() As Long
    hdc = mDC
End Property

Public Sub Paint(destdc As Long, _
                 DestX As Long, _
                 DestY As Long)
    
    BitBlt destdc, DestX, DestY, _
        mWidth, mHeight, mDC, _
        0, 0, vbSrcCopy
        
End Sub

Private Sub ClearAll()
    
    If (mDC <> API_NULL_HANDLE) Then
        If (mBitmap <> API_NULL_HANDLE) Then
            ' Select the original bitmap into the DC,
            ' and delete our bitmap
            SelectObject mDC, mOldBitmap
            DeleteObject mBitmap
            mBitmap = API_NULL_HANDLE
        End If
        
        ' Delete the memory DC
        DeleteObject mDC
        mDC = API_NULL_HANDLE
    End If

End Sub

Private Sub Class_Terminate()
    ClearAll
End Sub