cmultipgpreview_withchart.cls

打印预览程序

    If PrintFlag Then
        Printer.EndDoc
        Printer.ScaleMode = pSM
        SendToPrinter = False
    Else
        On Local Error Resume Next
        ObjPrint.ScaleMode = oSM
        
        SavePicture ObjPrint.Image, TempDir & "PPview" & CStr(PageNumber) & ".bmp"
    
        frmMultiPgPreview.PageNumber = PageNumber
        frmMultiPgPreview.Picture1.Picture = LoadPicture(TempDir & "PPview" & CStr(0) & ".bmp")
        frmMultiPgPreview.Show oModal, OwnerForm
    End If
End Sub

Public Sub pFontName(Optional ByVal pFontName As String = "Times New Roman")
    If PrintFlag Then
        Printer.FontName = pFontName
        Printer.Print "";
    Else
        ObjPrint.FontName = pFontName
        ObjPrint.Print "";
    End If
End Sub

Public Property Let FontSize(pSize As Integer)
    If PrintFlag Then
        Printer.FontSize = pSize
    Else
        ObjPrint.FontSize = pSize
    End If
End Property

Public Property Get FontSize() As Integer
    If PrintFlag Then
        FontSize = Printer.FontSize
    Else
        FontSize = ObjPrint.FontSize
    End If
End Property

Public Property Let ForeColor(NewColor As Long)
    If PrintFlag Then
        Printer.ForeColor = NewColor
    Else
        ObjPrint.ForeColor = NewColor
    End If
End Property

Public Property Get ForeColor() As Long
    If PrintFlag Then
        ForeColor = Printer.ForeColor
    Else
        ForeColor = ObjPrint.ForeColor
    End If
End Property

Public Sub pLine(Optional ByVal LeftMargin As Single = 0, _
                 Optional ByVal RightMargin As Single = 0, _
                 Optional ByVal LineWidth As Integer = 1, _
                 Optional IncludeSpace As Boolean = True)
  
  Dim eDrawWidth As Integer, cY As Single, cX As Single
    
    Select Case oScaleMode
    Case vbCentimeters
        cY = 0.07
    Case Else 'vbinches
        cY = 0.03
    End Select
    
    If IncludeSpace Then CurrentY = CurrentY + cY

    If LineWidth > 0 Then
        eDrawWidth = DrawWidth
        DrawWidth = LineWidth
    End If
    
    If PrintFlag Then
        cX = Printer.CurrentX
        If RightMargin <= LeftMargin Then RightMargin = PgWidth
        Printer.Line (LeftMargin, Printer.CurrentY)-(RightMargin, Printer.CurrentY)
        Printer.CurrentX = cX
    Else
        cX = ObjPrint.CurrentX
        If RightMargin <= LeftMargin Then RightMargin = PgWidth
        ObjPrint.Line (LeftMargin, ObjPrint.CurrentY)-(RightMargin, ObjPrint.CurrentY)
        ObjPrint.CurrentX = cX
    End If
    
    If LineWidth > 0 Then DrawWidth = eDrawWidth
    If IncludeSpace Then CurrentY = CurrentY + cY

End Sub

Public Sub pNewPage()

    On Local Error Resume Next
    If PrintFlag Then
        Printer.NewPage
    Else
        SavePicture ObjPrint.Image, TempDir & "PPview" & CStr(PageNumber) & ".bmp"
        ObjPrint.Cls
        PageNumber = PageNumber + 1
    End If
End Sub

Public Sub pPrint(Optional ByVal PrintVar As String = vbNullString, _
                  Optional ByVal LeftMargin As Single = -1, _
                  Optional SameLine As Boolean = False)

    If PrintVar = vbNullString Then
        '/* Empty String */
    Else
        If LeftMargin = -1 Then LeftMargin = CurrentX
        If (GetTextWidth(PrintVar) + LeftMargin > PgWidth) Or _
           InStr(PrintVar, vbCr) Or InStr(PrintVar, vbLf) Then
           
            pMultiline PrintVar, LeftMargin, PgWidth - 0.1, , SameLine
            Exit Sub
        End If
    End If
    
    If LeftMargin >= 0 Then CurrentX = LeftMargin
    
    If SameLine Then
        If PrintFlag Then
            Printer.Print PrintVar;
        Else
            ObjPrint.Print PrintVar;
        End If
    Else
        If PrintFlag Then
            Printer.Print PrintVar
        Else
            ObjPrint.Print PrintVar
        End If
    End If

End Sub

Public Sub pPrintedDate(Optional PrintCentered As Boolean = False, _
                        Optional ByVal LeftMargin As Single = -1, _
                        Optional SameLine As Boolean = False)
  
  Dim PrintVar As String
  Dim FSize As Integer, FBold As Boolean, FItalic As Boolean
  Dim FUnderline As Boolean, FStrikethru As Boolean
  
    FSize = FontSize
    FBold = FontBold
    FItalic = FontItalic
    FUnderline = FontUnderline
    FStrikethru = FontStrikethru
    
    FontSize = 9
    FontBold = False
    FontUnderline = False
    FontItalic = False
    FontStrikethru = False
    PrintVar = "Printed: " & Format(Now, "ddd. mmm. d, yyyy \@ h:mm ampm")
    
    If PrintCentered Then
        pCenter PrintVar, SameLine
    Else
        pPrint PrintVar, LeftMargin, SameLine
    End If
    
    FontSize = FSize
    FontBold = FBold
    FontItalic = FItalic
    FontUnderline = FUnderline
    FontStrikethru = FStrikethru

End Sub

Public Sub pStartDoc()

    PageNumber = 0
    TempDir = Environ("TEMP") & "\"
    
    On Local Error Resume Next
    
    '/* Set the Printer's scale mode
    pSM = Printer.ScaleMode
    Printer.ScaleMode = oScaleMode
    
    '/* Get the physical printable area
    PgWidth = Printer.ScaleWidth
    PgHeight = Printer.ScaleHeight
    
    If PrintFlag Then
        '/* Initialize printer
        Printer.Print "";
    Else
        '/* Initialize the preview object
        Load frmMultiPgPreview
        Set ObjPrint = frmMultiPgPreview!Picture1
        
        '/* Scale Object to Printer's printable area
        oSM = ObjPrint.ScaleMode
        ObjPrint.ScaleMode = oScaleMode
        
        '/* Full Page size (1440 twips = 1 inch or 567 twips = 1 centimeter)
        Select Case oScaleMode
        Case vbCentimeters
            ObjPrint.Width = (PgWidth + 0.6) * 567
            ObjPrint.Height = (PgHeight + 0.6) * 567
        Case Else 'vbinches
            ObjPrint.Width = (PgWidth + 0.25) * 1440
            ObjPrint.Height = (PgHeight + 0.25) * 1440
        End Select
        
        '/* Set default properties of the scroll bars
        frmMultiPgPreview!VScroll1.Max = Val(ObjPrint.Height * 0.5)
        frmMultiPgPreview!VScroll1.Min = -500
        frmMultiPgPreview!VScroll1.SmallChange = Val(frmMultiPgPreview!VScroll1.Max * 0.1)
        frmMultiPgPreview!VScroll1.LargeChange = Val(frmMultiPgPreview!VScroll1.Max * 0.5)
         
        frmMultiPgPreview!HScroll1.Max = Val(ObjPrint.Width * 0.25)
        frmMultiPgPreview!HScroll1.Min = -500
        frmMultiPgPreview!HScroll1.SmallChange = Val(frmMultiPgPreview!HScroll1.Max * 0.1)
        frmMultiPgPreview!HScroll1.LargeChange = Val(frmMultiPgPreview!HScroll1.Max * 0.5)
         
        '/* Set default properties of the object to match printer
        ObjPrint.Scale (0, 0)-(PgWidth, PgHeight)
        ObjPrint.FontName = Printer.FontName
        ObjPrint.FontSize = Printer.FontSize
        ObjPrint.ForeColor = Printer.ForeColor
        ObjPrint.Picture = Nothing
        
    End If

End Sub

Public Property Let FontBold(YesNo As Boolean)
    If PrintFlag Then
        Printer.FontBold = YesNo
    Else
        ObjPrint.FontBold = YesNo
    End If
End Property

Public Property Get FontBold() As Boolean
    If PrintFlag Then
        FontBold = Printer.FontBold
    Else
        FontBold = ObjPrint.FontBold
    End If
End Property

Public Property Let FontItalic(YesNo As Boolean)
    If PrintFlag Then
        Printer.FontItalic = YesNo
    Else
        ObjPrint.FontItalic = YesNo
    End If
End Property

Public Property Get FontItalic() As Boolean
    If PrintFlag Then
        FontItalic = Printer.FontItalic
    Else
        FontItalic = ObjPrint.FontItalic
    End If
End Property

Public Function pEndOfPage(Optional ByVal Less As Single = 0, Optional SaveRoomForFooter As Boolean = True) As Boolean
  Dim n As Single
  Dim fTextHeight As Single
  Dim eFontSize As Integer
    
    If PrintFlag Then
        '/* Make sure there is room for the footer
        fTextHeight = Printer.TextHeight("TextString")
        If SaveRoomForFooter Then
            eFontSize = Printer.FontSize
            Printer.FontSize = 10
            fTextHeight = Printer.TextHeight("TextString") * 2
            Printer.FontSize = eFontSize
        End If
        n = Printer.CurrentY + Printer.TextHeight("TextString") + fTextHeight + Less
    Else
        '/* Make sure there is room for the footer
        fTextHeight = ObjPrint.TextHeight("TextString")
        If SaveRoomForFooter Then
            eFontSize = ObjPrint.FontSize
            ObjPrint.FontSize = 10
            fTextHeight = ObjPrint.TextHeight("TextString") * 2
            ObjPrint.FontSize = eFontSize
        End If
        n = ObjPrint.CurrentY + ObjPrint.TextHeight("TextString") + fTextHeight + Less
    End If
    
    If n >= PgHeight Then
        pEndOfPage = True
    Else
        pEndOfPage = False
    End If
    
End Function

Public Property Let FontUnderline(YesNo As Boolean)
    If PrintFlag Then
        Printer.FontUnderline = YesNo
    Else
        ObjPrint.FontUnderline = YesNo
    End If
End Property

Public Property Get FontUnderline() As Boolean
    If PrintFlag Then
        FontUnderline = Printer.FontUnderline
    Else
        FontUnderline = ObjPrint.FontUnderline
    End If
End Property

Public Sub pHalfSpace()
  Dim eFont As Integer
  Dim hFont As Integer
 
    eFont = FontSize
    hFont = eFont \ 2
    If hFont < 1 Then hFont = 1
    FontSize = hFont
    pPrint
    FontSize = eFont
    
End Sub

Public Sub pDoubleLine(Optional ByVal LeftPos As Single = 0, _
                       Optional ByVal RightPos As Single = 0, _
                       Optional ByVal LineWidth As Integer = 1, _
                       Optional IncludeSpace As Boolean = True)
 
  Dim eFont As Integer, eDrawWidth As Integer
  Dim cY As Single, cX As Single
   
    cX = CurrentX
    Select Case oScaleMode
    Case vbCentimeters
        cY = 0.07
    Case Else 'vbinches
        cY = 0.03
    End Select
    
    eDrawWidth = DrawWidth
    If LineWidth > 0 Then DrawWidth = LineWidth
    'If IncludeSpace Then CurrentY = CurrentY + cY
    
    If PrintFlag Then
        cX = Printer.CurrentX
        If RightPos <= LeftPos Then RightPos = PgWidth
        Printer.CurrentY = Printer.CurrentY + cY
        Printer.Line (LeftPos, Printer.CurrentY)-(PgWidth, Printer.CurrentY)
        Printer.CurrentY = Printer.CurrentY + cY
        Printer.Line (LeftPos, Printer.CurrentY)-(PgWidth, Printer.CurrentY)
        Printer.CurrentY = Printer.CurrentY + cY
        Printer.CurrentX = cX
    Else
        cX = ObjPrint.CurrentX
        If RightPos <= LeftPos Then RightPos = PgWidth
        ObjPrint.CurrentY = ObjPrint.CurrentY + cY
        ObjPrint.Line (LeftPos, ObjPrint.CurrentY)-(PgWidth, ObjPrint.CurrentY)
        ObjPrint.CurrentY = ObjPrint.CurrentY + cY
        ObjPrint.Line (LeftPos, ObjPrint.CurrentY)-(PgWidth, ObjPrint.CurrentY)
        ObjPrint.CurrentY = ObjPrint.CurrentY + cY
        ObjPrint.CurrentX = cX
    End If
    
    If LineWidth > 0 Then DrawWidth = eDrawWidth
    If IncludeSpace Then CurrentY = CurrentY + cY

End Sub

Public Sub pVerticalLine(Optional ByVal LeftPos As Single = -1, _
                         Optional ByVal TopPos As Single = -1, _
                         Optional ByVal BottomPos As Single = -1, _
                         Optional ByVal LineWidth As Integer = 0)
 
  Dim eDrawWidth As Integer, cY As Single, cX As Single, tH As Single
  Dim eFontSize As Integer
   
    eDrawWidth = DrawWidth
    cX = CurrentX
    cY = CurrentY
    If LineWidth > 0 Then DrawWidth = LineWidth
    
    If BottomPos = -1 Then
        eFontSize = FontSize
        FontSize = 10
        BottomPos = PgHeight - (GetTextHeight * 2)
        FontSize = eFontSize
    End If
    
    If LeftPos = -1 Then LeftPos = CurrentX
    If LeftPos > PgWidth Then LeftPos = PgWidth - 0.01
    If TopPos = -1 Then TopPos = CurrentY

    If PrintFlag Then
        Printer.Line (LeftPos, TopPos)-(LeftPos, BottomPos)
    Else
        ObjPrint.Line (LeftPos, TopPos)-(LeftPos, BottomPos)
    End If
    
    CurrentX = cX
    CurrentY = cY