bitmapbuffer.cls

一个屏幕 动 画的演示程序(例子 )

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "BitMapBuffer"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

'This is the BitmapBuffer Class. It basically handles the creation
'and maintenance of Memory Device Contexts used to store graphic
'images in memory. You can use the BitmapBuffer for background images,
'sprite animations, scrolling backgrounds, and off-screen painting
'areas. The BitmapBuffer object has four properties & two methods:
'
'       BitmapFile  Indicates the path & filename of the bitmap that
'                   will be loaded into this BitmapBuffer. The BitmapBuffer
'                   also uses the dimensions of the bitmap to determine
'                   the size of the buffer. <PROPERTY> <READ/WRITE>
'
'       Handle      Returns the handle to the device context (hDC) of
'                   this BitmapBuffer.      <PROPERTY>  <READ-ONLY>
'
'       Height      Returns the Height of this BitmapBuffer
'                                           <Property>  <READ-ONLY>
'
'       Width       Returns the Width of this BitmapBuffer
'                                           <Property>  <READ-ONLY>
'
'       Create      Creates the memory device context for this BitmapBuffer
'                   and, optionally, loads the bitmap set by the
'                   BitmapFile property. If no BitmapFile is set,
'                   you need to specify the width and height of the
'                   BitmapBuffer when you use Create.   <METHOD>
'
'                   USAGE:  object.Create [Width] [,Height]
'
'       Destroy     Frees the resources used by this BitmapBuffer.
'                   Any BitmapBuffers you create are destroyed automatically
'                   if they are no longer referenced by your program.
'                   If you want to explicitly destroy it, use this method.
'
'                   USAGE:  object.Destroy

'Variables used internally by the BitmapBuffer Class
Private BufferhDC As Long       'Internal handle to the memory DC.
                                '  Used to return the Handle property.
Private OldObj As Long          'Used to store the old object (Windows stock bitmap)
                                '  when BitmapFile is selected into the DC
Private BufferBM As String      'Internal path & filename of the bitmap
                                '  Used to return the BitmapFile property.
Private BMWidth As Long         'Used to store the width of the Bitmap
                                '  and return the Width property
Private BMHeight As Long        'Used to store the Height of the Bitmap
                                '  and return the Height property

Property Let BitmapFile(ByVal NewBMFile As String)
'When the BitmapFile property is set, this procedure is called.
'It reads the header information of the bitmap to determine the
'width and height of the bitmap. It then sets the width and
'height of the buffer to match.

    Dim BMFileNum As Integer            'File handle for the bitmap
    Dim FileHeader As BITMAPFILEHEADER  'Bitmap file header structure
    Dim InfoHeader As BITMAPINFOHEADER  'Bitmap information structure
    
    'First, check to make sure the file specified by NewBMFile exists.
    If Dir(NewBMFile) = "" Then
        'If it doesn't, raise an error.
        Err.Raise Number:=vbObjectError, Description:=NewBMFile + " does not exist."
        BufferBM = ""
        Exit Property
    Else
        BufferBM = NewBMFile
    End If
    BMFileNum = FreeFile         'Gets the next free file handle
    Open BufferBM For Binary Access Read As #BMFileNum
        'Read the bitmap information
        Get #BMFileNum, , FileHeader
        Get #BMFileNum, , InfoHeader
    Close #BMFileNum
    
    'Make sure it's a 256-color bitmap.
    If InfoHeader.biBitCount > 8 Then
        Err.Raise Number:=vbObjectError + 32112, Description:="Incorrect bitmap format."
        BufferBM = ""
    End If
    
    'Make sure the width & height are greater than zero
    If InfoHeader.biHeight <= 0 Or InfoHeader.biWidth <= 0 Then
        Err.Raise Number:=vbObjectError + 32112, Description:="Incorrect bitmap size."
        BufferBM = ""
    Else
        'Set the Width & Height of the buffer.
        BMHeight = InfoHeader.biHeight
        BMWidth = InfoHeader.biWidth
    End If
End Property

Property Get BitmapFile() As String
'When the BitmapFile property is read, this procedure is invoked.
    'Return the path & name of the bitmap file.
    BitmapFile = BufferBM
End Property

Sub Create(Optional BufWidth As Variant, Optional BufHeight As Variant)
'When the Create method is invoked, this procedure is called
    'Check to see if BitmapFile is not set
    If BufferBM = "" Then
        'If it isn't, first check if the parameters BufWidth & BufHeight exist
        If IsMissing(BufWidth) Or IsMissing(BufHeight) Then Exit Sub
        'and if they do, are they greater than zero.
        If (BufWidth <= 0) And (BufHeight <= 0) Then
            'If they aren't, set the height & width to 0 and exit the procedure.
            BMWidth = 0
            BMHeight = 0
            Exit Sub
        Else
            'If they are, then set the width & height of the buffer
            BMWidth = BufWidth
            BMHeight = BufHeight
        End If
    End If
    'Create a memory device context (buffer)
    BufferhDC = NewDC(Screen.ActiveForm.hDC, BMWidth, BMHeight)
    'If BitmapFile is set, load the bitmap into the buffer
    If BufferBM <> "" Then OldObj = SelectObject(BufferhDC, LoadPicture(BufferBM))
End Sub

Sub Destroy()
'When the Destroy method is invoked, this procedure is called
    'Create a temporary variable to store the results
    'of the SelectObject function.
    Dim tmpObj As Long
    
    'Select the original object (Windows stock bitmap) back into the
    'memory DC. This basically restores things the way they were before
    'we created this BitmapBuffer.
    tmpObj = SelectObject(BufferhDC, OldObj)
    
    'Delete the memory DC and free the resources we used.
    DeleteDC BufferhDC
End Sub

Property Get Handle() As Long
'When the Handle property is read, this procedure is invoked.
    'Return the Handle of the BitmapBuffer.
    Handle = BufferhDC
End Property


Property Get Height()
'When the Height property is read, this procedure is invoked.
    'Return the height of the BitmapBuffer.
    Height = BMHeight
End Property

Property Get Width()
'When the Width property is read, this procedure is invoked.
    'Return the width of the BitmapBuffer.
    Width = BMWidth
End Property

Private Sub Class_Terminate()
'This procedure is invoked when no more instances of the
'BitmapBuffer class are referenced, such as when you
'end the program. This procedure is the same as the Destroy method.
    'Create a temporary variable to store the results
    'of the SelectObject function.
    Dim tmpObj As Long
    
    'Select the original object (Windows stock bitmap) back into the
    'memory DC. This basically restores things the way they were before
    'we created this BitmapBuffer.
    If OldObj > 0 Then tmpObj = SelectObject(BufferhDC, OldObj)
    
    'Delete the memory DC and free the resources we used.
    If BufferhDC > 0 Then DeleteDC BufferhDC
End Sub