clsmemdc.cls

VB做的报表设计源程序,非常不错,可以自定义模版

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsMemDC"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'////////////////////////////////////////////////////////
'///                  Memory DC Class
'///                   (clsMemDC.cls)
'///_____________________________________________________
'/// Memory DC for flicker free drawing.
'///_____________________________________________________
'/// Last modification  : Ago/07/2000
'/// Last modified by   : Leontti R.
'/// Modification reason: Created
'/// Project: RamoSoft Component Suite ' I borrowed this code from a another project from myself
'/// Author: Leontti A. Ramos M. ([e-mail])
'/// RamoSoft de Mexico S.A. de C.V.
'////////////////////////////////////////////////////////

'Note from RG (04/08/2006)
'   Modified this class to draw different shapes and 3 different check box styles (see DrawCheckBox)
'   modified drawing subs in Page class to match

Option Explicit

Public BackColor As OLE_COLOR
Private m_hWorkDC As Long
Private m_hBmpOld As Long
Private m_hBmp As Long
Private m_lWidth As Long
Private m_lHeight As Long
Private m_iScaleMode As ScaleModeConstants
Private m_iMFactor As Single
Private m_lOldFont As Long
Private Const PIXELS_PER_INCHE = 96
Private Const PIXELS_PER_CENTIMETER = 37.8
Private Const PIXELS_PER_POINT = 4.8
Private Const PIXELS_PER_PIXEL = 1
Private Const TWIPS_PER_POINT = 72
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
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function GetBkColor Lib "gdi32" (ByVal hDC As Long) As Long
Private Const ETO_CLIPPED = 4
Private Const ETO_OPAQUE = 2
' Bitmap copying related
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Private Declare Function SetBrushOrgEx Lib "gdi32" (ByVal hDC As Long, ByVal nXOrg As Long, ByVal nYOrg As Long, lppt As POINTAPI) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function LPtoDP Lib "gdi32" (ByVal hDC As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Private Const HALFTONE = 4
Private Const SRCCOPY = &HCC0020
' Drawing related functions
'Note from RG (04/08/2006) - added several drawing functions to allow different shapes to be drawn
Private Declare Function DrawTextAPI Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal HPALETTE As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function FillRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
Private Declare Function Arc Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long

Private Const PS_SOLID = 0
Private Const PS_DASH = 1                    '  -------
Private Const PS_DOT = 2                     '  .......
Private Const PS_DASHDOT = 3                 '  _._._._
Private Const PS_DASHDOTDOT = 4              '  _.._.._
Private Const DT_WORDBREAK = &H10
Private Const DT_VCENTER = &H4
Private Const DT_CENTER = &H1
Private Const DT_LEFT = &H0
Private Const DT_RIGHT = &H2
Private Const DT_NOPREFIX = &H800
Private Const BKMODE_OPAQUE = 2
Private Const BKMODE_TRANSPARENT = 1

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type POINTAPI
    X As Long
    Y As Long
End Type
' Font creation
Private Const CLIP_DEFAULT_PRECIS = 0 '*
Private Const PROOF_QUALITY = 2 '*
Private Const DEFAULT_PITCH = 0 '*
Private Const ANSI_CHARSET = 0 '*
Private Const DEFAULT_CHARSET = 1 '*
Private Const OEM_CHARSET = 255 '*
' Font Families
Private Const FF_DONTCARE = 0 '*    '  Don't care or don't know.
Private Const FF_ROMAN = 16      '  Variable stroke width, serifed.
' Font Weights
Private Const FW_NORMAL = 400 '*
Private Const FW_BOLD = 700 '*

Private Const OUT_DEFAULT_PRECIS = 0 '*
Private Const OUT_TT_ONLY_PRECIS = 7 '*

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(LF_FACESIZE) As Byte
End Type

Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function SetMapMode Lib "gdi32" (ByVal hDC As Long, ByVal nMapMode As Long) As Long

Private Const LOGPIXELSY = 90 '*        '  Logical pixels/inch in Y
Private Const MM_HIMETRIC = 3
Private Const MM_LOMETRIC = 2
' Bitmap info
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type


Friend Sub Dither(Optional hDC As Long)
    Dim LnStyle As Long
    Dim LhDC As Long
    Dim LhBrush As Long
    Dim LhOldBrush As Long
    Dim LoPattern As StdPicture
    
    If (hDC = 0) Then
        hDC = m_hWorkDC
    End If
    Set LoPattern = LoadResPicture(101, vbResBitmap)
    LhBrush = CreatePatternBrush(LoPattern.Handle)
    LhOldBrush = SelectObject(hDC, LhBrush)
    Call PatBlt(hDC, 0, 0, m_lWidth, m_lHeight, &HA000C9) '&HA0329) ' &HA000C9)
    LhOldBrush = SelectObject(hDC, LhOldBrush)
    Call DeleteObject(LhBrush)
End Sub


Public Sub DrawShape(ByVal iType As Integer, ByVal lLeft As Long, ByVal lTop As Long, _
    ByVal lWidth As Long, ByVal lHeight As Long, Optional lLineWidth As Integer = 1, _
    Optional lfColor As OLE_COLOR, Optional lbColor As OLE_COLOR = -1, Optional lPen As Long = 0)
    On Error GoTo ERR_H

'* Note from RG (04/08/2006)
'       Modified DrawBox sub to draw Rectangle, Square, Oval, Circle, Rounded Rectangle and Rounded Square
'       Renamed sub DrawShape

    Dim LnTop As Long
    Dim LnLeft As Long
    Dim LnWidth As Long
    Dim LnHeight As Long
    Dim LrBox As RECT
    Dim LrPos As POINTAPI
    Dim lhPen As Long
    Dim LhOldPen As Long
    Dim LhBrush As Long
    
    If iType = 0 Or iType = 2 Or iType = 4 Then     'if rectangle, ellipse or rounded rectangle
        With LrBox
            .Left = lLeft
            .Top = lTop
            .Right = lLeft + lWidth
            .Bottom = lTop + lHeight
        End With
    Else                                            'otherwise will be square, circle or rounded square
        With LrBox
            If lWidth < lHeight Then
                .Top = lTop + (lHeight / 2) - (lWidth / 2)
                lHeight = lWidth
                .Left = lLeft
            Else
                .Left = lLeft + (lWidth / 2) - (lHeight / 2)
                lWidth = lHeight
                .Top = lTop
            End If
            .Right = .Left + lWidth
            .Bottom = .Top + lHeight
        End With
    End If
    
    If iType < 2 Then      'rectangle or square
        If (lbColor <> -1) Then
            LhBrush = CreateSolidBrush(lbColor)
            Call FillRect(m_hWorkDC, LrBox, LhBrush)
            Call DeleteObject(LhBrush)
        End If
        
        If (lfColor <> -1) Then
            If (lLineWidth = 0) Then
                lhPen = CreatePen(PS_DOT, 1, lfColor)
            Else
                lhPen = CreatePen(lPen, lLineWidth, lfColor)
            End If
            If (lhPen <> 0) Then
                LhOldPen = SelectObject(m_hWorkDC, lhPen)
            End If
            With LrBox
                MoveToEx m_hWorkDC, .Left, .Top, LrPos
                LineTo m_hWorkDC, .Right, .Top
                LineTo m_hWorkDC, .Right, .Bottom
                LineTo m_hWorkDC, .Left, .Bottom
                LineTo m_hWorkDC, .Left, .Top
            End With
            If lhPen Then
                Call SelectObject(m_hWorkDC, LhOldPen)
                Call DeleteObject(lhPen)
            End If
        End If
    
    ElseIf iType < 4 Then           'ellipse or circle
        Dim EllipReg As Long
        EllipReg = CreateEllipticRgn(LrBox.Left, LrBox.Top, LrBox.Right, LrBox.Bottom)
        If (lbColor <> -1) Then
            LhBrush = CreateSolidBrush(lbColor)
            Call FillRgn(m_hWorkDC, EllipReg, LhBrush)
            Call DeleteObject(LhBrush)
        End If
    
        If (lfColor <> -1) Then
            If (lLineWidth = 0) Then
                lhPen = CreatePen(PS_DOT, 1, lfColor)
            Else
                lhPen = CreatePen(lPen, lLineWidth, lfColor)
            End If
            If (lhPen <> 0) Then
                LhOldPen = SelectObject(m_hWorkDC, lhPen)
            End If
        
            Call Arc(m_hWorkDC, LrBox.Left, LrBox.Top, LrBox.Right, LrBox.Bottom, _
            LrBox.Right, LrBox.Top + (LrBox.Bottom - LrBox.Top) / 2, LrBox.Right, LrBox.Top + (LrBox.Bottom - LrBox.Top) / 2)
        
            If lhPen Then
                Call SelectObject(m_hWorkDC, LhOldPen)
                Call DeleteObject(lhPen)
            End If
        End If
    
    ElseIf iType < 6 Then          'rounded rectangle or rounded square
        Dim RnRcReg As Long
        Dim ArcDiam As Long
        Dim LineOffset As Long
        If (LrBox.Right - LrBox.Left) < (LrBox.Bottom - LrBox.Top) Then
            ArcDiam = (LrBox.Right - LrBox.Left) / 4
        Else
            ArcDiam = (LrBox.Bottom - LrBox.Top) / 4
        End If
        LineOffset = ArcDiam / 2
        RnRcReg = CreateRoundRectRgn(LrBox.Left, LrBox.Top, LrBox.Right, LrBox.Bottom, ArcDiam, ArcDiam)
        If (lbColor <> -1) Then
            LhBrush = CreateSolidBrush(lbColor)
            Call FillRgn(m_hWorkDC, RnRcReg, LhBrush)
            Call DeleteObject(LhBrush)
        End If
        
        If (lfColor <> -1) Then
            If (lLineWidth = 0) Then
                lhPen = CreatePen(PS_DOT, 1, lfColor)
            Else
                lhPen = CreatePen(lPen, lLineWidth, lfColor)
            End If
            If (lhPen <> 0) Then
                LhOldPen = SelectObject(m_hWorkDC, lhPen)
            End If