page.cls

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

            m_PaperSize = vbPRPSUser
        End If
    Else
        m_PaperSize = vbPRPSUser
    End If
    m_bLandScape = (m_nDisplayWidth > m_nDisplayHeight)
End Sub

Public Property Get SectionType() As Integer
    SectionType = m_iSectionType
End Property

Public Property Let SectionType(iType As Integer)
    m_iSectionType = iType
End Property


Friend Sub SetPaperProps(ByVal iPaperSize As Integer, _
    iScaleMode As ScaleModeConstants, iMFactor As Single, _
    lWidth As Single, lHeight As Single, bLandscape As Boolean)
    m_PaperSize = iPaperSize
    m_iScaleMode = iScaleMode
    m_iMFactor = iMFactor
    m_nDisplayWidth = lWidth
    m_nDisplayHeight = lHeight
    m_bLandScape = bLandscape
End Sub

'Public Sub AddElement(iType As Integer, lLeft As Long, lTop As Long, _
'    lWidth As Long, lHeight As Long, Optional nSize As Single = 1, _
'    Optional lBackColor As Long = -1, Optional lForeColor As Long = -1, _
'    Optional sText As String, Optional lFlags As Long, _
'    Optional oPicture As StdPicture, Optional iFontIndex As Integer)
'    m_iElementsCount = (m_iElementsCount + 1)
'    ReDim Preserve m_oElements(1 To m_iElementsCount)
'    With m_oElements(m_iElementsCount)
'        .Type = iType
'        .Left = lLeft
'        .Top = lTop
'        .Width = lWidth
'        .Height = lHeight
'        .Text = sText
'        .Size = nSize
'        .BackColor = lBackColor
'        .ForeColor = lForeColor
'        .Aligment = lFlags
'        If (iFontIndex = 0) Then
'            .FontIndex = Parent.FontMap.ActiveFont.Index
'        Else
'            .FontIndex = iFontIndex
'        End If
'        Set .Picture = oPicture
'    End With
'End Sub

Public Property Get PaperSize() As Integer
    PaperSize = m_PaperSize
End Property

Public Function SetFont(FaceName As String, Size As Single, _
    Optional Bold As Boolean, Optional Italic As Boolean, _
    Optional Underline As Boolean, Optional Strikethrough As Boolean, _
    Optional Rotation As Integer) As Integer
    SetFont = Parent.FontMap.Add(FaceName, Size, Bold, _
        Italic, Underline, Strikethrough, Rotation)
End Function

Public Property Get Count() As Integer
    Count = m_oElements.Count
End Property

Public Property Get DisplayWidth() As Long
    DisplayWidth = m_nDisplayWidth
End Property

Public Property Get DisplayHeight() As Long
    DisplayHeight = m_nDisplayHeight
End Property

Public Sub DrawText(sText As String, lLeft As Single, lTop As Single, _
    lWidth As Single, lHeight As Single, _
    Optional lfColor As OLE_COLOR = vbBlack, Optional lbColor As OLE_COLOR = -1, _
    Optional lAligment As Long, Optional iFontIndex As Integer)
    Dim LrElement As PageElement
    
    With LrElement
        .Type = TYPE_TEXT
        #If KEEP_VALUES Then
        .OrigLeft = lLeft
        .OrigTop = lTop
        .OrigWidth = lWidth
        .OrigHeight = lHeight
        #End If
        .Left = (lLeft * m_iMFactor)
        .Top = (lTop * m_iMFactor)
        .Width = (lWidth * m_iMFactor)
        .Height = (lHeight * m_iMFactor)
        .Text = sText
        .BackColor = lbColor
        .ForeColor = lfColor
        .Aligment = lAligment
        If (iFontIndex = 0) Then
            .FontIndex = Parent.FontMap.ActiveFont.Index
        Else
            .FontIndex = iFontIndex
        End If
        .SectionType = m_iSectionType
    End With
    m_oElements.Add LrElement
End Sub

Private Sub prvSetPrinterPage()
    On Error GoTo ERR_TRAP
    Printer.ScaleMode = m_iScaleMode
'    Printer.ScaleMode = vbPixels
    Select Case PaperSize
        Case vbPRPSLetter, vbPRPSLegal, vbPRPSA4
            Printer.PaperSize = m_PaperSize
        Case Else
            With Printer
                .PaperSize = vbPRPSUser
                .Width = m_nDisplayWidth
                .Height = m_nDisplayHeight
                .ScaleWidth = m_nDisplayWidth
                .ScaleHeight = m_nDisplayHeight
            End With
    End Select
    Printer.ScaleMode = m_iScaleMode
    Printer.Orientation = IIf(m_bLandScape, vbPRORLandscape, vbPRORPortrait)
    Exit Sub
ERR_TRAP:
    If (Err.Number = 380) Then Resume Next
    'Me.RaiseErr Err.Number, "prvSetPrinterPage"
End Sub

Public Property Get Element(Index As Integer) As PageElement
    Element = m_oElements.Item(Index)
End Property

Public Property Get Enabled() As Boolean
    Enabled = Range.ElementInRange(m_iIndex)
End Property

Public Property Get Index() As Integer
    Index = m_iIndex
End Property

Friend Property Let Index(iIndex As Integer)
    m_iIndex = iIndex
End Property

Public Property Get Parent() As Pages
    Dim lObjTmp As Object
        ' Turn the pointer into an illegal, uncounted interface
    CopyMemory lObjTmp, m_lParentPtr, 4
    ' Do NOT hit the End button here! You will crash!
    ' Assign to legal reference
    Set Parent = lObjTmp
    ' Still do NOT hit the End button here! You will still crash!
    ' Destroy the illegal reference
    CopyMemory lObjTmp, 0&, 4
End Property

Friend Property Get Range() As clsRangeSelector
    Dim lObjTmp As Object
        ' Turn the pointer into an illegal, uncounted interface
    CopyMemory lObjTmp, m_lRangePtr, 4
    ' Do NOT hit the End button here! You will crash!
    ' Assign to legal reference
    Set Range = lObjTmp
    ' Still do NOT hit the End button here! You will still crash!
    ' Destroy the illegal reference
    CopyMemory lObjTmp, 0&, 4
End Property

Friend Property Set Parent(oParent As Pages)
    m_lParentPtr = ObjPtr(oParent)
End Property

Friend Property Set Range(oRange As clsRangeSelector)
    m_lRangePtr = ObjPtr(oRange)
End Property

Public Sub SetActive()
    Parent.SelectPage m_iIndex
End Sub

Public Sub Clear()
    With m_oElements
        While .Count
            .Remove .Count
        Wend
    End With
    m_iSectionType = 0
End Sub

Public Property Let Landscape(ByVal vData As Boolean)
    Dim LnTemp As Long
    
    m_bLandScape = vData
    If m_bLandScape Then
        If (m_nDisplayWidth < m_nDisplayHeight) Then
            LnTemp = m_nDisplayWidth
            m_nDisplayWidth = m_nDisplayHeight
            m_nDisplayHeight = LnTemp
        End If
    Else
        If (m_nDisplayWidth > m_nDisplayHeight) Then
            LnTemp = m_nDisplayWidth
            m_nDisplayWidth = m_nDisplayHeight
            m_nDisplayHeight = LnTemp
        End If
    End If
End Property

Public Property Get Landscape() As Boolean
    Landscape = m_bLandScape
End Property

Public Property Let Height(ByVal vData As Single)
    m_nScaledHeight = vData
    m_nDisplayHeight = (m_nScaledHeight * m_iMFactor)
    prvValidatePaperSize
End Property

Public Sub StoreSection()
    m_iStoredSection = m_iSectionType
End Sub

Public Sub RestoreSection()
    m_iSectionType = m_iStoredSection
End Sub

Public Property Get Width() As Single
    Width = m_nScaledWidth
End Property

Public Property Get Height() As Single
    Height = m_nScaledHeight
End Property

Public Property Let Width(ByVal vData As Single)
    m_nScaledWidth = vData
    m_nDisplayWidth = (m_nScaledWidth * m_iMFactor)
    prvValidatePaperSize
End Property

Friend Sub RaiseErr(ByVal lErrNum As RSErrorCode, Optional sRoutineName As String, _
    Optional sDescription As String)
    RaiseError lErrNum, TypeName(Me), sRoutineName, sDescription, Erl
End Sub

Private Sub prvPrintShape(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 prvPrintBox sub to draw Rectangle, Square, Oval, Circle, Rounded Rectangle and Rounded Square
'       Renamed sub prvPrintShape

    Dim LhDC As Long
    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
    
    LhDC = Printer.hDC
    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
            ' Now converts coordinates to printer ratio
            .Left = (.Left - m_lPrnGapX)
            .Top = (.Top - m_lPrnGapY)
            .Right = (.Right - m_lPrnGapX)
            .Bottom = (.Bottom - m_lPrnGapY)
        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
        
            ' Now converts coordinates to printer ratio
            .Left = (.Left - m_lPrnGapX)
            .Top = (.Top - m_lPrnGapY)
            .Right = (.Right - m_lPrnGapX)
            .Bottom = (.Bottom - m_lPrnGapY)
        End With
    End If
    
    If iType < 2 Then      'rectangle or square
        If (lbColor <> -1) Then
            LhBrush = CreateSolidBrush(lbColor)
            Call FillRect(LhDC, 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(LhDC, lhPen)
            End If
            With LrBox
                MoveToEx LhDC, .Left, .Top, LrPos
                LineTo LhDC, .Right, .Top
                LineTo LhDC, .Right, .Bottom