apidevicecontext.cls

几个不错的VB例子

'\\ More advanced text, with bounding box etc.
Private Declare Function ExtTextOut Lib "gdi32" Alias "ExtTextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal wOptions As Long, lpRect As RECT, ByVal lpString As String, ByVal nCount As Long, lpDx As Long) As Long

'\\ Font manipulation....
Private mPrevFont As Long

'\\ GDI Objects....
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private mInitialFont As ApiLogFont
Private mInitialPen As ApiLogPen
Private mInitialBrush As ApiLogBrush

'\\ Region drawing functions....
Private Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
Private Declare Function FrameRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

'\\ Compatible device context creation...
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

'\\ Member variables...
Private mHDC As Long

Public Property Set BackgroundColour(ByVal newCol As ApiColour)

Call SetBkColor(mHDC, newCol.ColourRef)
If Err.LastDllError > 0 Then
    ReportError Err.LastDllError, "ApiDeviceContext:BackgroundColour", GetLastSystemError
End If

End Property

Public Property Get BackgroundColour() As ApiColour

Dim colThis As ApiColour
Dim lColRef As Long

Set colThis = New ApiColour
lColRef = GetBkColor(mHDC)
If Err.LastDllError > 0 Then
    ReportError Err.LastDllError, "ApiDeviceContext:BackgroundColour", GetLastSystemError
End If

Set BackgroundColour = colThis

End Property


'PUBLIC PROPERTY GET
Public Property Get BitsPerPixel() As Long

    BitsPerPixel = GetDeviceCaps(cBITSPIXEL)
    
End Property


'\\ --[BlockTransferBitData]-------------------------------------------------------------------------
'\\ Transfers the data from a rectangle section of a device context to a rectangle section of this
'\\ device context.
'\\ -------------------------------------------------------------------------------------------------
Public Sub BlockTransferBitData(ByVal Source As ApiDeviceContext, ByVal SourceSection As APIRect, ByVal TargetSection As APIRect, ByVal Operation As RasterOperationCodes)

Dim lret As Long

lret = StretchBlt(mHDC, TargetSection.Left, TargetSection.Top, _
                  TargetSection.Right - TargetSection.Left, _
                  TargetSection.Bottom - TargetSection.Top, _
                  Source.hdc, SourceSection.Left, _
                  SourceSection.Top, _
                  SourceSection.Right - SourceSection.Left, _
                  SourceSection.Bottom - SourceSection.Top, Operation)
                  
If Err.LastDllError > 0 Then
    ReportError Err.LastDllError, "ApiDeviceContext:BlockTransferBitData", GetLastSystemError
End If

End Sub

Public Property Get Brushes() As Collection

Dim colBrushes As Collection

Set colBrushes = GetDCBrushCollection(mHDC)

If Err.LastDllError Then
    ReportError Err.LastDllError, "ApiDeviceContext:Brushes", GetLastSystemError
End If

Set Brushes = colBrushes

End Property

Public Property Set BrushOrigin(ByVal neworigin As APIPoint)

Dim ptTemp As POINTAPI

Call SetBrushOrgEx(mHDC, neworigin.x, neworigin.y, ptTemp)
If Err.LastDllError > 0 Then
    ReportError Err.LastDllError, "ApiDeviceContext:BrushOrigin", GetLastSystemError
End If

End Property

Public Property Get BrushOrigin() As APIPoint

Dim ptThis As APIPoint
Dim ptTemp As POINTAPI

Set ptThis = New APIPoint

Call GetBrushOrgEx(mHDC, ptTemp)
If Err.LastDllError > 0 Then
    ReportError Err.LastDllError, "ApiDeviceContext:BrushOrigin (Get)", GetLastSystemError
Else
    ptThis.CreateFromPointer VarPtr(ptTemp)
End If

Set BrushOrigin = ptThis

End Property

Public Property Get ClipingCapabilities() As enClipCapabilities

    ClipingCapabilities = GetDeviceCaps(cCLIPCAPS)

End Property


Public Property Get ColourAdjustment() As ApiColourAdjustment

Dim mCol As ApiColourAdjustment

Set mCol = New ApiColourAdjustment
Set mCol.ParentDC = Me

Set ColourAdjustment = mCol

End Property

Public Property Get ColourPlanes() As Long

    ColourPlanes = GetDeviceCaps(cPLANES)
    
End Property

Public Property Get ColourResolution() As Long

    ColourResolution = GetDeviceCaps(cCOLORRES)

End Property

Public Function CreateCompatibleBitmap(ByVal bmWidth As Long, ByVal bmHeight As Long) As ApiBitmap

Dim bitmapThis As ApiBitmap

Set bitmapThis = New ApiBitmap

bitmapThis.CreateCompatibleBitmap mHDC, bmWidth, bmHeight

Set CreateCompatibleBitmap = bitmapThis

End Function

Public Property Get CurveCapability(ByVal Capability As enCurvecapabilities) As Boolean

Dim lret As Long

lret = GetDeviceCaps(cCURVECAPS)
CurveCapability = (lret And Capability)

End Property

Public Property Get DeviceType() As enDisplayTypes

DeviceType = GetDeviceCaps(cTECHNOLOGY)

End Property


Public Sub DrawFrameButton(ByVal RectIn As APIRect, ByVal ButtonStyle As enDrawFrameButton, ByVal ButtonState As enDrawFrameButtonState)

Dim lStyle As Long

lStyle = (ButtonStyle Or ButtonState)

Call DrawFrameControl(RectIn, DFC_BUTTON, lStyle)

End Sub

'\\ --[DrawFrameCaption]------------------------------------------------------------------
'\\ Draws a caption rectangle in the given RECT
'\\ ---------------------------------------------------------------------------------
Public Sub DrawFrameCaption(ByVal RectIn As APIRect, ByVal CaptionStyle As enDrawFrameCaption)

Call DrawFrameControl(RectIn, DFC_CAPTION, CaptionStyle)

End Sub


'\\ --[DrawEdge]----------------------------------------------------------
'\\ Draws the edge of the rectangle in RectIn as per the parameters passed
'\\ in.
'\\ Parameters:
'\\     Edge - The type of edge to draw (sunken,raised etc)
'\\     Flags - A combination of enBorderFlags to set which edges to draw
'\\ ----------------------------------------------------------------------
Public Sub DrawEdge(ByVal RectIn As APIRect, ByVal Edge As enEdgeBorderStyles, ByVal flags As Long)

Dim lret As Long
Dim rcThis As RECT

With rcThis
    .Bottom = RectIn.Bottom
    .Left = RectIn.Left
    .Right = RectIn.Right
    .Top = RectIn.Top
End With

lret = DrawEdgeApi(mHDC, rcThis, Edge, flags)
If (Err.LastDllError <> 0) Or (lret = 0) Then
    '\\ An error occured
    Call ReportError(Err.LastDllError, "ApiDeviceContext:DrawEdge", GetLastSystemError)
End If

End Sub

Private Sub DrawFrameControl(ByVal RectIn As APIRect, ByVal FrameType As enDrawFrameControlTypes, ByVal Style As Long)

Dim rcThis As RECT
Dim lret  As Long

With rcThis
    .Bottom = RectIn.Bottom
    .Left = RectIn.Left
    .Right = RectIn.Right
    .Top = RectIn.Top
End With

lret = DrawFrameControlApi(mHDC, rcThis, FrameType, Style)
If (Err.LastDllError > 0) Or (lret = 0) Then
    Call ReportError(Err.LastDllError, "ApiDeviceContext:DrawFrameControl", GetLastSystemError)
End If

End Sub

Public Sub DrawFrameMenu(ByVal RectIn As APIRect, ByVal MenuStyle As enDrawFrameMenu)

Call DrawFrameControl(RectIn, DFC_MENU, MenuStyle)

End Sub

Public Sub DrawFramePopup(ByVal RectIn As APIRect, ByVal Style As enDrawFrameMenuPopupMenu)

Call DrawFrameControl(RectIn, DFC_POPUPMENU, Style)

End Sub

Public Sub DrawFrameScroll(ByVal RectIn As APIRect, ByVal ScrollStyle As enDrawFrameScroll)

Call DrawFrameControl(RectIn, DFC_SCROLL, ScrollStyle)

End Sub

Public Sub DrawIcon(ByVal xPos As Long, ByVal yPos As Long, ByVal Icon As ApiIcon)

Dim lret As Long

lret = DrawIconApi(mHDC, xPos, yPos, Icon.hIcon)
If (Err.LastDllError > 0) Or (lret = 0) Then
    Call ReportError(Err.LastDllError, "ApiDeviceContext:DrawIcon", GetLastSystemError)
End If

End Sub

'\\ --[DrawRegion]-----------------------------------------------------------
'\\ Draws the region passed in on the current device context,
'\\ according to the brush and width/height or filled properties
'\\ -------------------------------------------------------------------------
Public Sub DrawRegion(ByVal rgnIn As ApiRegion, ByVal brshIn As ApiLogBrush, ByVal LineWidth As Long, ByVal LineHeight As Long, ByVal Fill As Boolean)

Dim lret As Long

If Fill Then
    lret = FillRgn(mHDC, rgnIn.hRgn, brshIn.Handle)
Else
    lret = FrameRgn(mHDC, rgnIn.hRgn, brshIn.Handle, LineWidth, LineHeight)
End If
If Err.LastDllError Then
    ReportError Err.LastDllError, "ApiDeviceContext:DrawRegion", GetLastSystemError
End If

End Sub

Public Property Get DriverVersion() As Long

    DriverVersion = GetDeviceCaps(cDRIVERVERSION)
    
End Property


Private Function GetDeviceCaps(ByVal dcIndex As enDeviceCapsIndexes) As Long

GetDeviceCaps = GetDeviceCapsApi(mHDC, dcIndex)

End Function






Public Property Get GraphicsMode() As enGraphicMode

Dim lret As Long

lret = GetGraphicsModeApi(mHDC)
If Err.LastDllError > 0 Or lret = 0 Then
   Call ReportError(Err.LastDllError, "ApiDeviceContext:GraphicsMode (Get)", GetLastSystemError)
End If
GraphicsMode = lret

End Property

Public Property Let GraphicsMode(ByVal gmNew As enGraphicMode)

Dim lret As Long

lret = SetGraphicsModeApi(mHDC, gmNew)
If Err.LastDllError Then
    ReportError Err.LastDllError, "ApiDeviceContext:GraphicsMode (Set)", GetLastSystemError
End If

End Property

Public Property Get hdc() As Long

    hdc = mHDC
    
End Property

Public Property Let hdc(ByVal newHDC As Long)

    mHDC = newHDC
    
End Property
Public Property Get Height(ByVal MeasurementScale As enDeviceMesaurementScale) As Long

If MeasurementScale = DMS_Millimeters Then
    Height = GetDeviceCaps(cVERTSIZE)
Else
    Height = GetDeviceCaps(cVERTRES)
End If

End Property

Public Property Get HorizontalTextAlignment() As HorizontalTextAlignments

Dim lAlign As Long

lAlign = mTextAlign

Select Case True
Case lAlign And TA_RTLREADING
    HorizontalTextAlignment = TA_RTLREADING
Case lAlign And TA_CENTRE
    HorizontalTextAlignment = TA_CENTRE
Case lAlign And TA_RIGHT
    HorizontalTextAlignment = TA_RIGHT
Case Else