page.cls

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

                            With LoFMap.Item(LnFntIdx)
                                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
                            LhOldFntIdx = LnFntIdx
                        End If
                        Call prvPrintText(.Text, (.Left * m_sS2PRatioX), (.Top * m_sS2PRatioY), _
                            (.Width * m_sS2PRatioX), (.Height * m_sS2PRatioY), .ForeColor, .BackColor, .Aligment)
                    Case TYPE_LINE
                        Call prvPrintLine((.Left * m_sS2PRatioX), (.Top * m_sS2PRatioY), _
                            (.Width * m_sS2PRatioX), (.Height * m_sS2PRatioY), _
                            .ForeColor, CInt(.Size * m_sS2PRatioY), .Pen)
                    Case TYPE_BOX
                        Call prvPrintShape(.DisplayType, (.Left * m_sS2PRatioX), (.Top * m_sS2PRatioY), _
                            (.Width * m_sS2PRatioX), (.Height * m_sS2PRatioY), _
                            CInt(.Size * m_sS2PRatioY), .ForeColor, .BackColor, .Pen)
                    Case TYPE_CHKBOX
                        Call prvPrintCheckBox(.DisplayType, .Checked, (.Left * m_sS2PRatioX), (.Top * m_sS2PRatioY), _
                        (.Width * m_sS2PRatioX), (.Height * m_sS2PRatioY), CInt(.Size * m_sS2PRatioY), .ForeColor, .BackColor, .Sunken)
                    Case TYPE_PICT
                        Call prvPrintPicture(.Picture, (.Left * m_sS2PRatioX), (.Top * m_sS2PRatioY), _
                            (.Width * m_sS2PRatioX), (.Height * m_sS2PRatioY))
                End Select
            End With
            DoEvents
        Next
        ' Restores Original Font
        #If USE_LOG_FONT Then
        LhOldFont = SelectObject(Printer.hDC, LhOldFont)
        #Else
        #End If
    End If
    Exit Sub
ERR_H:
    Me.RaiseErr Err.Number, Err.Source, Err.Description
End Sub

Private Sub prvPrintText(ByVal sText As String, ByVal lLeft As Long, ByVal lTop As Long, _
    ByVal lWidth As Long, ByVal lHeight As Long, ByVal lfColor As OLE_COLOR, _
    ByVal lbColor As OLE_COLOR, ByVal lFlags As Long)
    On Error GoTo ERR_H
    Dim LhDC  As Long
    Dim lBrush As Long
    Dim LnOldBMode As Long
    Dim LrBox As RECT
    
    LhDC = Printer.hDC
'////////////////////////////////////////
'///      Coordenates Calculation
'////////////////////////////////////////
    With LrBox
        .Left = (lLeft - m_lPrnGapX)
        .Top = (lTop - m_lPrnGapY)
        .Right = (.Left + lWidth)
        .Bottom = (.Top + lHeight)
    End With
'////////////////////////////////////////
'///       Defaults Resolution
'////////////////////////////////////////
    If (lFlags = 0) Then
        lFlags = (DT_WORDBREAK Or DT_LEFT)
    ElseIf (lFlags = 1) Then
        lFlags = (DT_WORDBREAK Or DT_RIGHT)
    ElseIf (lFlags = 2) Then
        lFlags = (DT_WORDBREAK Or DT_CENTER)
    End If
    If (lfColor = -1) Then
        lfColor = vbBlack
    End If
'////////////////////////////////////////
'///         Background Drawing
'///_____________________________________
'/// If background is not transparent
'/// (<> -1) then draws it...
'////////////////////////////////////////
    If (lbColor <> -1) Then
        lBrush = CreateSolidBrush(lbColor)
        Call FillRect(LhDC, LrBox, lBrush)
        DeleteObject (lBrush)
    End If
'////////////////////////////////////////
'///           Text Drawing
'////////////////////////////////////////
    LnOldBMode = SetBkMode(LhDC, BKMODE_TRANSPARENT)
'    #If USE_LOG_FONT Then
    Call SetTextColor(LhDC, lfColor)
    DrawTextAPI LhDC, sText, Len(sText), LrBox, lFlags Or DT_NOPREFIX
'    #Else
'    Printer.FillColor = lFColor
'    printer.CurrentX=
'    #End If
    Call SetBkMode(LhDC, LnOldBMode)
    Exit Sub
ERR_H:
    Me.RaiseErr Err.Number, "DrawText"
End Sub

Private Sub prvPrintLine(lX1 As Long, lY1 As Long, lX2 As Long, lY2 As Long, _
    lColor As OLE_COLOR, Optional lWidth As Long = 1, Optional lPen As Long)
    
    On Error GoTo ERR_H
    Dim LhDC As Long
    Dim LrPos As POINTAPI
    Dim lhPen As Long
    Dim LhOldPen As Long
    Dim LrBox As RECT
    
    ' Gets printer DC
    LhDC = Printer.hDC
    ' Converts coordinates
    With LrBox
        .Left = (lX1 - m_lPrnGapX)
        .Top = (lY1 - m_lPrnGapY)
        .Right = (lX2 - m_lPrnGapX)
        .Bottom = (lY2 - m_lPrnGapY)
    End With
    ' Creates apropiate pen and selects it in the DC
    If (lWidth = 0) Then
        lhPen = CreatePen(PS_DOT, 1, lColor)
    Else
        lhPen = CreatePen(lPen, lWidth, lColor)
    End If
    If lhPen Then
        LhOldPen = SelectObject(LhDC, lhPen)
    End If
    ' Draws box lines
    With LrBox
        MoveToEx LhDC, .Left, .Top, LrPos
        LineTo LhDC, .Right, .Bottom
    End With
    If lhPen Then
        Call SelectObject(LhDC, LhOldPen)
        Call DeleteObject(lhPen)
    End If
    Exit Sub
ERR_H:
    Me.RaiseErr Err.Number, "DrawLine"
End Sub

Private Sub prvPrintPicture(oPicture As StdPicture, lLeft As Long, lTop As Long, _
    lWidth As Long, lHeight As Long, Optional bKeepRatio As Boolean = True, _
    Optional bVCenter As Boolean = True, Optional bHCenter As Boolean = True, Optional lPen As Long)
    On Error GoTo ERR_H
#Const USE_PALETTE = True
#Const USE_DISPLAY = False
#Const USE_BITBLT = True
#Const USE_BKMODE = False
#Const USE_HALFTONE = False
    Dim LhDC As Long
    Dim LhDCTemp As Long
    Dim LhOldPalette As Long
    Dim LhOldBitmap As Long
    Dim LrPoint As POINTAPI
    Dim LrReal As RECT
    Dim LrBitmap As BITMAP
    #If USE_HALFTONE Then
    Dim LnOldStrMode As Long
    #End If
    
    ' Gets printer DC
    LhDC = Printer.hDC
    'Validate that a bitmap was passed in
    If (oPicture.Type = vbPicTypeBitmap) Then
        With oPicture
            ' get bitmap info
            GetObjectAPI .Handle, Len(LrBitmap), LrBitmap   'dest
            #If USE_DISPLAY Then
            Dim LhDC As Long
            LhDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
            LhDCTemp = CreateCompatibleDC(LhDC)
            DeleteDC LhDC
            #Else
            LhDCTemp = CreateCompatibleDC(LhDC)
            #End If
            #If USE_PALETTE Then
            LhOldPalette = SelectPalette(LhDCTemp, .hPal, True)
            RealizePalette LhDCTemp
            #End If
            'Select bitmap into DC
            LhOldBitmap = SelectObject(LhDCTemp, .Handle)
        End With
        #If USE_BITBLT Then
        If ((lWidth = LrBitmap.bmWidth) And (lHeight = LrBitmap.bmHeight)) Then
            #If USE_HALFTONE Then
            LnOldStrMode = SetStretchBltMode(LhDC, HALFTONE)
            #End If
            BitBlt LhDC, lLeft, lTop, lWidth, lHeight, LhDCTemp, 0, 0, SRCCOPY
            #If USE_HALFTONE Then
            LnOldStrMode = SetStretchBltMode(LhDC, LnOldStrMode)
            #End If
        Else
        #Else
        If True Then
        #End If
            With LrReal
                If bKeepRatio Then
                    Dim LnRatio As Single
                    Dim LnDrwRatio As Single
                    Dim LnImgRatio As Single
                    
                    With LrBitmap
                        LnDrwRatio = (lHeight / lWidth)
                        LnImgRatio = (.bmHeight / .bmWidth)
                        If (LnDrwRatio > LnImgRatio) Then
                            LnRatio = (lWidth / .bmWidth)
                        Else
                            LnRatio = (lHeight / .bmHeight)
                        End If
                    End With
                    ' Used for width & height
                    .Right = (LrBitmap.bmWidth * LnRatio)
                    .Bottom = (LrBitmap.bmHeight * LnRatio)
                    ' Left & Top positions
                    If bHCenter Then
                        .Left = (lLeft + ((lWidth - .Right) / 2))
                    Else
                        .Left = lLeft
                    End If
                    If bVCenter Then
                        .Top = (lTop + ((lHeight - .Bottom) / 2))
                    Else
                        .Top = lTop
                    End If
                    ' Now converts coordinates to printer ratio
                    .Left = (.Left - m_lPrnGapX)
                    .Top = (.Top - m_lPrnGapY)
                    .Right = (.Right - m_lPrnGapX)
                    .Bottom = (.Bottom - m_lPrnGapY)
                Else
                    .Left = (lLeft - m_lPrnGapX)
                    .Top = (lTop - m_lPrnGapY)
                    ' Used for width & height
                    .Right = (lWidth - m_lPrnGapX)
                    .Bottom = (lHeight - m_lPrnGapY)
                End If
                'Copy to destination DC
                #If USE_BKMODE Then
                Dim LnOldBkColor As Long
                LnOldBkColor = SetBkColor(LhDC, 0&)
                #End If
                #If USE_HALFTONE Then
                LnOldStrMode = SetStretchBltMode(LhDC, HALFTONE)
                #End If
                Call SetBrushOrgEx(LhDC, 0, 0, LrPoint)
                Call StretchBlt(LhDC, .Left, .Top, .Right, .Bottom, LhDCTemp, 0, 0, LrBitmap.bmWidth, LrBitmap.bmHeight, SRCCOPY)
                #If USE_BKMODE Then
                LnOldBkColor = SetBkColor(LhDC, LnOldBkColor)
                #End If
                #If USE_HALFTONE Then
                LnOldStrMode = SetStretchBltMode(LhDC, LnOldStrMode)
                #End If
            End With
        End If
        'Cleanup
        SelectObject LhDCTemp, LhOldBitmap
        #If USE_PALETTE Then
        SelectPalette LhDCTemp, LhOldPalette, True
        RealizePalette LhDCTemp
        #End If
        DeleteDC LhDCTemp
    Else
        Me.RaiseErr ecInvalidObjType, "DrawPicture", "Invalid picture format."
    End If
    Exit Sub
ERR_H:
    Me.RaiseErr Err.Number, "DrawPicture"
End Sub

Private Sub prvGetPrn2ScrRatio()
    Dim LhDC As Long
    Dim LnScrResX As Long
    Dim LnScrResY As Long
    Dim LnPrnResX As Long
    Dim LnPrnResY As Long
    ' Gets Screen logical inches resolution
    LhDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
    LnScrResX = GetDeviceCaps(LhDC, LOGPIXELSX)
    LnScrResY = GetDeviceCaps(LhDC, LOGPIXELSY)
    DeleteDC LhDC
    ' Gets Printer logical inches resolution
    With Printer
        LnPrnResX = GetDeviceCaps(.hDC, LOGPIXELSX)
        LnPrnResY = GetDeviceCaps(.hDC, LOGPIXELSY)
        ' Gets Screen logical inches resolution
        m_lPrnGapX = GetDeviceCaps(.hDC, PHYSICALOFFSETX)
        m_lPrnGapY = GetDeviceCaps(.hDC, PHYSICALOFFSETY)
    End With
    m_sS2PRatioX = (LnPrnResX / LnScrResX)
    m_sS2PRatioY = (LnPrnResY / LnScrResY)
End Sub


Private Sub prvValidatePaperSize()
    If (m_nDisplayWidth = 816) Then ' Letter, A4 or Legal (Portrait)
        Select Case m_nDisplayHeight
            Case 1056 ' Letter
                m_PaperSize = vbPRPSLetter
            Case 1152 ' A4
                m_PaperSize = vbPRPSA4
            Case 1344 ' Legal
                m_PaperSize = vbPRPSLegal
            Case Else ' User
                m_PaperSize = vbPRPSUser
        End Select
    ElseIf (m_nDisplayWidth = 1056) Then ' Letter
        If (m_nDisplayHeight = 816) Then ' Letter
            m_PaperSize = vbPRPSLetter
        Else ' User
            m_PaperSize = vbPRPSUser
        End If
    ElseIf (m_nDisplayWidth = 1152) Then ' A4
        If (m_nDisplayHeight = 816) Then ' A4
            m_PaperSize = vbPRPSA4
        Else ' User
            m_PaperSize = vbPRPSUser
        End If
    ElseIf (m_nDisplayWidth = 1344) Then ' Legal
        If (m_nDisplayHeight = 816) Then ' Legal
            m_PaperSize = vbPRPSLegal
        Else ' User