page.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 = "Page"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
'////////////////////////////////////////////////////////
'///                 Output Page Class
'///                    (Page.cls)
'///_____________________________________________________
'/// This class mimics a printer page, it let us call
'/// 'Draw' methods that adds page elements as data structure.
'/// Printer information is stored here (Paper size, Port,
'/// Paper Try, etc.). The resulting pages could be exported
'/// to printer or any serial format as Text, HTML, RTF, etc.
'///_____________________________________________________
'/// Last modification  : Ago/10/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.
'////////////////////////////////////////////////////////
Option Explicit
#Const KEEP_VALUES = False

Private m_iSectionType As Integer
Private m_iStoredSection As Integer

Public Type PageElement
    Text As String
    Left As Long
    Top As Long
    Width As Long
    Height As Long
    #If KEEP_VALUES Then
    OrigLeft As Single
    OrigTop As Single
    OrigWidth As Single
    OrigHeight As Single
    #End If
    BackColor As Long
    Pen As Long
    ForeColor As Long
    Aligment As Long
    Type As Integer
    Size As Single
    Picture As StdPicture
    FontIndex As Integer
    BandIndex As Integer
    SectionType As Integer
    DisplayType As Integer
    Sunken As Boolean
    Checked As Boolean
End Type

Private m_oElements As Collection
Private m_lParentPtr As Long
Private m_lRangePtr As Long
Private m_iIndex As Long

Private m_iScaleMode As ScaleModeConstants
Private m_iMFactor As Single
Private m_PaperSize As Integer
Private m_nDisplayWidth As Single
Private m_nDisplayHeight As Single
Private m_nScaledWidth As Single
Private m_nScaledHeight As Single
Private m_bLandScape As Boolean
' Ratio conversion
Private m_sS2PRatioX As Single
Private m_sS2PRatioY As Single
Private m_lPrnGapX As Integer
Private m_lPrnGapY As Integer

Public PrinterPort As String
Public PrinterTray As Integer

Private Const TYPE_TEXT = 1
Private Const TYPE_LINE = 2
Private Const TYPE_BOX = 3
Private Const TYPE_PICT = 4
Private Const TYPE_CHKBOX = 5

Private Const TWIPS_PER_INCHE = 1440
Private Const TWIPS_PER_CENTIMETER = 567
Private Const TWIPS_PER_POINT = 72
Private Const TWIPS_PER_PIXEL = 15
Private Const TWIPS_PER_TWIP = 1

'Drawing functions
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 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 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 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 CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) 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 Const BKMODE_TRANSPARENT = 1
' System related
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Const TECHNOLOGY = 2 ' Device type returns DT_PLOTTER, DT_RASDISPLAY, DT_RASPRINTER, DT_RASCAMERA, DT_CHARSTREAM, DT_METAFILE, or DT_DISPFILE
Private Const DT_PLOTTER = 0 ' Vector plotter
Private Const DT_RASDISPLAY = 1 ' Raster display
Private Const DT_RASPRINTER = 2 ' Raster printer
Private Const DT_RASCAMERA = 3 ' Raster camera
Private Const DT_CHARSTREAM = 4 ' Character stream
Private Const DT_CENTER = &H1
Private Const DT_LEFT = &H0
Private Const DT_RIGHT = &H2
Private Const VERTSIZE = 6 ' Width, in millimeters, of the physical screen.
Private Const HORZSIZE = 4 ' Height, in millimeters, of the physical screen.
Private Const HORZRES = 8  ' Width, in pixels, of the screen.
Private Const VERTRES = 10 ' Height, in raster lines, of the screen.
Private Const LOGPIXELSX = 88 ' (&H58) Number of pixels per logical inch along the screen width.
Private Const LOGPIXELSY = 90 ' (&H5A) Number of pixels per logical inch along the screen height.' For printing devices:
Private Const PHYSICALWIDTH = 110 ' (&H6E) The physical width, in device units.
Private Const PHYSICALHEIGHT = 111 ' (&H6F) The physical height, in device units.
Private Const PHYSICALOFFSETX = 112 ' (&H70) The physical printable area horizontal margin.
Private Const PHYSICALOFFSETY = 113 '(&H71) The physical printable area vertical margin.
Private Const SCALINGFACTORX = 114 ' (&H72)  The scaling factor along the horizontal axis.
Private Const SCALINGFACTORY = 115 ' (&H73  The scaling factor along the vertical axis.

Public Sub DrawShape(iType As Integer, Left As Single, Top As Single, _
    Width As Single, Height As Single, _
    Optional lForeColor As OLE_COLOR, Optional lBackColor As OLE_COLOR = -1, _
    Optional iLineWidth As Integer = 1, Optional lPen As Long = 0)
    Dim LrElement As PageElement
    
    With LrElement
        .Type = TYPE_BOX
        #If KEEP_VALUES Then
        .OrigLeft = Left
        .OrigTop = Top
        .OrigWidth = Width
        .OrigHeight = Height
        #End If
        .Left = (Left * m_iMFactor)
        .Top = (Top * m_iMFactor)
        .Width = (Width * m_iMFactor)
        .Height = (Height * m_iMFactor)
        .BackColor = lBackColor
        .ForeColor = lForeColor
        .Size = iLineWidth
        .Pen = lPen
        .SectionType = m_iSectionType
        .DisplayType = iType
    End With
    m_oElements.Add LrElement
End Sub

Public Sub DrawCheckBox(ByVal iType As Integer, ByVal blnChecked As Boolean, _
    ByVal lLeft As Single, ByVal lTop As Single, Width As Single, Height As Single, Optional lfColor As OLE_COLOR, _
    Optional lbColor As OLE_COLOR = -1, Optional iLineWidth As Integer = 1, Optional blnSunken As Boolean)
    
    Dim LrElement As PageElement

    With LrElement
        .Type = TYPE_CHKBOX
        #If KEEP_VALUES Then
        .OrigLeft = lLeft
        .OrigTop = lTop
        #End If
        .Left = (lLeft * m_iMFactor)
        .Top = (lTop * m_iMFactor)
        .Width = (Width * m_iMFactor)
        .Height = (Height * m_iMFactor)
        .ForeColor = lfColor
        .BackColor = lbColor
        .SectionType = m_iSectionType
        .DisplayType = iType
        .Size = iLineWidth
        .Sunken = blnSunken
        .Checked = blnChecked
    End With
    m_oElements.Add LrElement

End Sub

Public Sub DrawLine(X1 As Single, Y1 As Single, _
    X2 As Single, Y2 As Single, _
    Optional lColor As OLE_COLOR, Optional iWidth As Integer = 1, Optional lPen As Long = 0)
    Dim LrElement As PageElement
    
    With LrElement
        .Type = TYPE_LINE
        #If KEEP_VALUES Then
        .OrigLeft = X1
        .OrigTop = Y1
        .OrigWidth = X2
        .OrigHeight = Y2
        #End If
        .Left = (X1 * m_iMFactor)
        .Top = (Y1 * m_iMFactor)
        .Width = (X2 * m_iMFactor)
        .Height = (Y2 * m_iMFactor)
        .Size = iWidth
        .Pen = lPen
        .ForeColor = lColor
        .SectionType = m_iSectionType
    End With
    m_oElements.Add LrElement
End Sub

Public Sub DrawPicture(Left As Single, Top As Single, _
    Width As Single, Height As Single, _
    oPicture As StdPicture, Optional bKeepRatio As Boolean = True, _
    Optional sFileName As String)
    Dim LrElement As PageElement
    
    With LrElement
        .Type = TYPE_PICT
        #If KEEP_VALUES Then
        .OrigLeft = Left
        .OrigTop = Top
        .OrigWidth = Width
        .OrigHeight = Height
        #End If
        .Left = (Left * m_iMFactor)
        .Top = (Top * m_iMFactor)
        .Width = (Width * m_iMFactor)
        .Height = (Height * m_iMFactor)
        Set .Picture = oPicture
        .Text = sFileName
        .SectionType = m_iSectionType
    End With
    m_oElements.Add LrElement
End Sub

Friend Property Get Elements() As Collection
    Set Elements = m_oElements
End Property

Public Sub NewSection()
    m_iSectionType = (m_iSectionType + 1)
End Sub

Friend Sub PrintIt()
    If (Printers.Count = 0) Then
        Exit Sub
    End If
    Dim LnIdx As Long
    Dim LoRange As clsRangeSelector
    Dim LoFMap As FontMap
    Dim LhOldFont As Long
    Dim LhOldFntIdx As Integer
    
    On Error GoTo ERR_H
    Set LoRange = Range
    Set LoFMap = Parent.FontMap
    ' Verify if is a printable page....
    If (LoRange.ElementInRange(m_iIndex)) Then
        If (m_iIndex = LoRange.RangeMin) Then
            ' This is the first printed page
            Printer.KillDoc
        Else
            Printer.NewPage
        End If
        If (PrinterPort <> Printer.Port) Then
        '////////////////////////////////////////////////
        '/// TODO: Code for Printer Change on the Fly ///
        '////////////////////////////////////////////////
        End If
        If (PrinterTray <> Printer.PaperBin) Then
            On Error Resume Next
            Printer.PaperBin = PrinterTray
            On Error GoTo 0
        End If
        ' Adjust conversion ratio
        prvGetPrn2ScrRatio
        ' Prepare Printer page
        prvSetPrinterPage
        ' Inits page
        On Error GoTo ERR_H
        Printer.Print ""
        ' Prints page elements
        ' Stores original Font object
        LhOldFntIdx = 1
        #If USE_LOG_FONT Then
        LhOldFont = SelectObject(Printer.hDC, LoFMap.Item(LhOldFntIdx).Handle)
        #Else
        With LoFMap.Item(1)
            Printer.FontName = .FaceName
            Printer.FontSize = .Size
            Printer.FontBold = .Bold
            Printer.FontItalic = .Italic
            Printer.FontUnderline = .Underline
            Printer.FontStrikethru = .Strikethrough
            Printer.FontTransparent = True
            Printer.Print ""
        End With
        #End If
        If (m_oElements.Count > 0) Then
            Printer.Print ""
        End If
        DoEvents
        For LnIdx = 1 To m_oElements.Count
            With m_oElements.Item(LnIdx)
                Printer.CurrentX = 0
                Printer.CurrentY = 0
                Select Case .Type
                    Case TYPE_TEXT
                        If (LhOldFntIdx <> .FontIndex) Then
                            Dim LnFntIdx As Integer
                            
                            LnFntIdx = .FontIndex
                            #If USE_LOG_FONT Then
                            Call SelectObject(Printer.hDC, LoFMap.Item(LnFntIdx).Handle)
                            Printer.Print ""
                            #Else