apibitmap.cls

来自「几个不错的VB例子」· CLS 代码 · 共 114 行

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

' ##MODULE_DESCRIPTION This class returns information about and allows the manipulation of bitmaps


Private mhBitmap As Long

Private Type Size
    cx As Long
    cy As Long
End Type
Private Declare Function GetBitmapDimensionExApi Lib "gdi32" Alias "GetBitmapDimensionEx" (ByVal hBitmap As Long, lpDimension As Size) As Long


Private mStockBitmap As Boolean

Private Declare Function DeleteObjectApi Lib "gdi32" Alias "DeleteObject" (ByVal hObject As Long) As Long

Private Declare Function CreateCompatibleBitmapApi Lib "gdi32" Alias "CreateCompatibleBitmap" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long



Friend Sub CreateCompatibleBitmap(ByVal hdc As Long, ByVal Width As Long, ByVal Height As Long)

Dim lret As Long

lret = CreateCompatibleBitmapApi(hdc, Width, Height)
If lret = 0 Or Err.LastDllError > 0 Then
    Call ReportError(Err.LastDllError, "CreateCompatibleBitmap", GetLastSystemError)
Else
    mhBitmap = lret
End If

End Sub


Public Property Get hBitmap() As Long

    hBitmap = mhBitmap
    
End Property

Public Property Let hBitmap(ByVal newhandle As Long)

    If mhBitmap <> newhandle Then
        mhBitmap = newhandle
    End If
    
End Property

'\\ --[Height]------------------------------------------------------------------------------
'\\ Returns the height of a bitmap in logical pixels
'\\ ----------------------------------------------------------------------------------------
'\\ (c) 2001 - Merrion Computing.  All rights  to use, reproduce or publish this code reserved
'\\ Please check http://www.merrioncomputing.com for updates.
'\\ ----------------------------------------------------------------------------------------
Public Property Get Height() As Long

Dim nSize As Size
Dim lret As Long

lret = GetBitmapDimensionExApi(mhBitmap, nSize)
If lret = 0 Or Err.LastDllError > 0 Then
    Call ReportError(Err.LastDllError, "ApiBitmap:Height", GetLastSystemError)
Else
    Height = nSize.cy
End If

End Property

'\\ --[Width]------------------------------------------------------------------------------
'\\ Returns the width of a bitmap in logical pixels
'\\ ----------------------------------------------------------------------------------------
'\\ (c) 2001 - Merrion Computing.  All rights  to use, reproduce or publish this code reserved
'\\ Please check http://www.merrioncomputing.com for updates.
'\\ ----------------------------------------------------------------------------------------
Public Property Get Width() As Long

Dim nSize As Size
Dim lret As Long

lret = GetBitmapDimensionExApi(mhBitmap, nSize)
If lret = 0 Or Err.LastDllError > 0 Then
    Call ReportError(Err.LastDllError, "ApiBitmap:Width", GetLastSystemError)
Else
    Width = nSize.cx
End If

End Property

Private Sub Class_Terminate()

Dim lret As Long

If mhBitmap > 0 And Not (mStockBitmap) Then
    lret = DeleteObjectApi(mhBitmap)
    If lret = 0 Or Err.LastDllError > 0 Then
        Call ReportError(Err.LastDllError, "ApiBitmap:Terminate", GetLastSystemError)
    End If
End If

End Sub