page.cls

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

                LineTo LhDC, .Left, .Bottom
                LineTo LhDC, .Left, .Top
            End With
            If lhPen Then
                Call SelectObject(LhDC, 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(LhDC, 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(LhDC, lhPen)
            End If
        
            Call Arc(LhDC, 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(LhDC, 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(LhDC, 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(LhDC, lhPen)
            End If
        
            MoveToEx LhDC, LrBox.Left + LineOffset, LrBox.Top, LrPos
            LineTo LhDC, LrBox.Right - LineOffset, LrBox.Top
            MoveToEx LhDC, LrBox.Right, LrBox.Top + LineOffset, LrPos
            LineTo LhDC, LrBox.Right, LrBox.Bottom - LineOffset
            MoveToEx LhDC, LrBox.Right - LineOffset, LrBox.Bottom, LrPos
            LineTo LhDC, LrBox.Left + LineOffset, LrBox.Bottom
            MoveToEx LhDC, LrBox.Left, LrBox.Bottom - LineOffset, LrPos
            LineTo LhDC, LrBox.Left, LrBox.Top + LineOffset
        
            Arc LhDC, LrBox.Right - ArcDiam, LrBox.Top, LrBox.Right, LrBox.Top + ArcDiam, _
            LrBox.Right, LrBox.Top + LineOffset, LrBox.Right - LineOffset, LrBox.Top
            
            Arc LhDC, LrBox.Right - ArcDiam, LrBox.Bottom - ArcDiam, LrBox.Right, LrBox.Bottom, _
            LrBox.Right - LineOffset, LrBox.Bottom, LrBox.Right, LrBox.Bottom - LineOffset
            
            Arc LhDC, LrBox.Left, LrBox.Bottom - ArcDiam, LrBox.Left + ArcDiam, LrBox.Bottom, _
            LrBox.Left, LrBox.Bottom - LineOffset, LrBox.Left + LineOffset, LrBox.Bottom
            
            Arc LhDC, LrBox.Left, LrBox.Top, LrBox.Left + ArcDiam, LrBox.Top + ArcDiam, _
            LrBox.Left + LineOffset, LrBox.Top, LrBox.Left, LrBox.Top + LineOffset
        
            If lhPen Then
                Call SelectObject(LhDC, LhOldPen)
                Call DeleteObject(lhPen)
            End If
        End If
    
    End If
    
    Exit Sub

ERR_H:
    Me.RaiseErr Err.Number, "DrawShape"
End Sub

Public Sub prvPrintCheckBox(ByVal iType As Integer, ByVal blnChecked As Boolean, 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 = -1, Optional lbColor As OLE_COLOR = -1, Optional blnSunken As Boolean)
    
    On Error GoTo ERR_H
    Dim LhDC As Long
    Dim LnTop As Long
    Dim LnLeft 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 Then       'box with check mark
        With LrBox
            .Left = lLeft
            .Top = lTop + (lHeight * 0.1875)
            .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
        
        If (lbColor <> -1) Then
            LhBrush = CreateSolidBrush(lbColor)
            Call FillRect(LhDC, LrBox, LhBrush)
            Call DeleteObject(LhBrush)
        End If
    
        lhPen = CreatePen(PS_SOLID, lLineWidth, lfColor)
        If (lhPen <> 0) Then
            LhOldPen = SelectObject(LhDC, lhPen)
        End If
        If blnSunken Then
            MoveToEx LhDC, LrBox.Left + (lWidth * 0.0833), LrBox.Top + (lHeight * 0.9375), LrPos
            LineTo LhDC, LrBox.Left + (lWidth * 0.0833), LrBox.Top + (lHeight * 0.25)
            LineTo LhDC, LrBox.Left + (lWidth * 0.9167), LrBox.Top + (lHeight * 0.25)
        End If
        With LrBox
            MoveToEx LhDC, .Left, .Top, LrPos
            LineTo LhDC, .Right, .Top
            LineTo LhDC, .Right, .Bottom
            LineTo LhDC, .Left, .Bottom
            LineTo LhDC, .Left, .Top
        End With
        
        If blnChecked Then
            lhPen = CreatePen(PS_SOLID, lLineWidth * 3, lfColor)
            If (lhPen <> 0) Then
                LhOldPen = SelectObject(LhDC, lhPen)
            End If
            MoveToEx LhDC, LrBox.Left + (lWidth * 0.25), LrBox.Top + (lHeight * 0.4375), LrPos
            LineTo LhDC, LrBox.Left + (lWidth * 0.5), LrBox.Top + (lHeight * 0.8125)
            LineTo LhDC, LrBox.Left + (lWidth * 0.833), LrBox.Top
        End If
        
    ElseIf iType = 1 Then       'round radio button with center dot
        With LrBox
            .Left = lLeft
            .Top = lTop
            .Right = lLeft + (lWidth * 1.0833)
            .Bottom = lTop + (lHeight * 0.8125)
            
            ' Now converts coordinates to printer ratio
            .Left = (.Left - m_lPrnGapX)
            .Top = (.Top - m_lPrnGapY)
            .Right = (.Right - m_lPrnGapX)
            .Bottom = (.Bottom - m_lPrnGapY)
        End With
        
        Dim lEllReg As Long
        If (lbColor <> -1) Then
            lEllReg = CreateEllipticRgn(LrBox.Left, LrBox.Top, LrBox.Right, LrBox.Bottom)
            LhBrush = CreateSolidBrush(lbColor)
            Call FillRgn(LhDC, lEllReg, LhBrush)
            Call DeleteObject(LhBrush)
        End If
        
        lhPen = CreatePen(PS_SOLID, lLineWidth * 2, lfColor)
        If (lhPen <> 0) Then
            LhOldPen = SelectObject(LhDC, lhPen)
        End If

        Call Arc(LhDC, LrBox.Left, LrBox.Top, LrBox.Right, LrBox.Bottom, _
        LrBox.Left + (lWidth * 0.5), LrBox.Top, LrBox.Left + (lWidth * 0.5), LrBox.Top)
        
        If blnSunken Then
            Call Arc(LhDC, LrBox.Left + (lWidth * 0.0833), LrBox.Top + (lHeight * 0.0625), LrBox.Right, LrBox.Bottom, _
            LrBox.Left + (lWidth * 0.5), LrBox.Top, LrBox.Left + (lWidth * 0.5), LrBox.Top)
        End If

        If blnChecked Then
            With LrBox
                .Left = lLeft + (lWidth * 0.25)
                .Top = lTop + (lWidth * 0.25)
                .Right = lLeft + (lWidth * 0.9167)
                .Bottom = lTop + (lHeight * 0.6875)
                
                ' Now converts coordinates to printer ratio
                .Left = (.Left - m_lPrnGapX)
                .Top = (.Top - m_lPrnGapY)
                .Right = (.Right - m_lPrnGapX)
                .Bottom = (.Bottom - m_lPrnGapY)
                
                lEllReg = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
            End With
            
            LhBrush = CreateSolidBrush(lfColor)
            Call FillRgn(LhDC, lEllReg, LhBrush)
            Call DeleteObject(LhBrush)
        End If
        
    ElseIf iType = 2 Then       'box with X in it
        With LrBox
            .Left = lLeft
            .Top = lTop
            .Right = lLeft + lWidth
            .Bottom = lTop + lHeight * 0.75
        
            ' Now converts coordinates to printer ratio
            .Left = (.Left - m_lPrnGapX)
            .Top = (.Top - m_lPrnGapY)
            .Right = (.Right - m_lPrnGapX)
            .Bottom = (.Bottom - m_lPrnGapY)
        End With
        
        If (lbColor <> -1) Then
            LhBrush = CreateSolidBrush(lbColor)
            Call FillRect(LhDC, LrBox, LhBrush)
            Call DeleteObject(LhBrush)
        End If
    
        lhPen = CreatePen(PS_SOLID, lLineWidth, lfColor)
        If (lhPen <> 0) Then
            LhOldPen = SelectObject(LhDC, lhPen)
        End If
        
        If blnSunken Then
            MoveToEx LhDC, LrBox.Left + (lWidth * 0.0833), LrBox.Top + (lHeight * 0.75), LrPos
            LineTo LhDC, LrBox.Left + (lWidth * 0.0833), LrBox.Top + (lHeight * 0.0625)
            LineTo LhDC, LrBox.Left + (lWidth * 0.9167), LrBox.Top + (lHeight * 0.0625)
        End If
        
        With LrBox
            MoveToEx LhDC, .Left, .Top, LrPos
            LineTo LhDC, .Right, .Top
            LineTo LhDC, .Right, .Bottom
            LineTo LhDC, .Left, .Bottom
            LineTo LhDC, .Left, .Top
        End With
        
        If blnChecked Then
            lhPen = CreatePen(PS_SOLID, lLineWidth * 2, lfColor)
            If (lhPen <> 0) Then
                LhOldPen = SelectObject(LhDC, lhPen)
            End If
            MoveToEx LhDC, LrBox.Left + (lWidth * 0.25), LrBox.Top + (lWidth * 0.25), LrPos
            LineTo LhDC, LrBox.Left + (lWidth * 0.833), LrBox.Top + (lHeight * 0.625)
            MoveToEx LhDC, LrBox.Left + (lWidth * 0.25), LrBox.Top + (lHeight * 0.625), LrPos
            LineTo LhDC, LrBox.Left + (lWidth * 0.833), LrBox.Top + (lHeight * 0.1875)
        End If
        
    End If
    
    Exit Sub

ERR_H:
    Me.RaiseErr Err.Number, "DrawCheckBox"

End Sub

Public Property Let PaperSize(iSize As Integer)
    m_PaperSize = iSize
    Select Case m_PaperSize
        Case vbPRPSLetter ' Letter
            If m_bLandScape Then
                m_nDisplayWidth = 1056
                m_nDisplayHeight = 816
            Else
                m_nDisplayWidth = 816
                m_nDisplayHeight = 1056
            End If
        Case vbPRPSA4 ' A4
            If m_bLandScape Then
                m_nDisplayWidth = 1152
                m_nDisplayHeight = 816
            Else
                m_nDisplayWidth = 816
                m_nDisplayHeight = 1152
            End If
        Case vbPRPSLegal ' Legal
            If m_bLandScape Then
                m_nDisplayWidth = 1344
                m_nDisplayHeight = 816
            Else
                m_nDisplayWidth = 816
                m_nDisplayHeight = 1344
            End If
        Case Else ' User
            m_PaperSize = vbPRPSUser
    End Select
End Property

Private Sub Class_Initialize()
    Set m_oElements = New Collection
    m_nDisplayWidth = 816 ' 8.5 inches to pixels
    m_nDisplayHeight = 1056 '11 inches to pixels
    m_iScaleMode = vbInches
    m_PaperSize = vbPRPSLetter
    m_bLandScape = False
    PrinterTray = vbPRBNAuto
    If (Printers.Count = 0) Then
        PrinterPort = "[Unknown]"
    Else
        PrinterPort = Printer.Port
    End If
End Sub