cmultipgpreview_withchart.cls

打印预览程序

    
    If LineWidth > 0 Then DrawWidth = eDrawWidth
End Sub

Public Sub pSpaces(Optional ByVal RightMargin As Single = -1, _
                   Optional ByVal LeftMargin As Single = -1, _
                   Optional UseSymbol As Boolean = False)
  
  Dim xFontname As String
  Dim xForeColor As Long
  Dim tString As String
    
    xFontname = FontName
    xForeColor = ForeColor
    
    If LeftMargin <> -1 Then CurrentX = LeftMargin
    If RightMargin = -1 Then RightMargin = PgWidth
    
    If UseSymbol Then
        FontName = "Symbol"
        tString = "\"
        ForeColor = vbGreen
    Else
        tString = " "
    End If
    
    If CurrentX >= RightMargin Then GoTo ExitSpaceSub
    Do
        pPrint tString, , True
    Loop Until CurrentX >= RightMargin
    
ExitSpaceSub:
    FontName = xFontname
    ForeColor = xForeColor

End Sub

Public Sub p15Space()
  Dim eFont As Integer
  Dim hFont As Integer
    
    pPrint
    eFont = FontSize
    hFont = eFont \ 2
    FontSize = hFont
    pPrint
    FontSize = eFont
End Sub

Public Sub pFooter()
  Dim eFontS As Integer
  Dim eFontN As String
  Dim eFontB As Boolean
  Dim eFontI As Boolean
  Dim eFontU As Boolean
  Dim eFontK As Boolean
  Dim tMargin As Single
      
    Select Case oScaleMode
    Case vbCentimeters
        tMargin = 1.25
    Case Else 'vbinches
        tMargin = 0.5
    End Select

    '/* Save current setting
    eFontN = FontName
    eFontS = FontSize
    eFontB = FontBold
    eFontI = FontItalic
    eFontU = FontUnderline
    eFontK = FontStrikethru
    
    '/* Change settings
    pFontName
    FontSize = 10
    FontBold = False
    FontItalic = False
    FontUnderline = False
    FontStrikethru = False
    CurrentY = PgHeight - (GetTextHeight * 2)
    pLine , , 6
    
    pPrint "Printed: " & Format(Now, "ddd. mmmm d, yyyy \@ h:mm ampm"), tMargin, True
    pRightJust "Pg. " & GetPage, PgWidth - tMargin
    
    '/* Restore setting
    FontName = eFontN
    FontSize = eFontS
    FontBold = eFontB
    FontItalic = eFontI
    FontUnderline = eFontU
    FontStrikethru = eFontK
   
End Sub
Public Sub pHeader(ByVal MainTitle As String, Optional SubTitle As String = vbNullString, Optional ItalicMain As Boolean = True)
  Dim eFontS As Integer
  Dim eFontN As String
  Dim eFontB As Boolean
  Dim eFontI As Boolean
  Dim eFontU As Boolean
  Dim eFontK As Boolean
      
    '/* Save current setting
    eFontN = FontName
    eFontS = FontSize
    eFontB = FontBold
    eFontI = FontItalic
    eFontU = FontUnderline
    eFontK = FontStrikethru
    CurrentY = 0
    CurrentX = 0
    
    '/* Change settings
    pFontName
    FontSize = 16
    FontBold = True
    FontItalic = ItalicMain
    pCenter MainTitle

    FontSize = 11
    FontBold = False
    FontItalic = False
    If SubTitle > vbNullString Then pCenter SubTitle
    pDoubleLine
    pHalfSpace
    
    '/* Restore setting
    FontName = eFontN
    FontSize = eFontS
    FontBold = eFontB
    FontItalic = eFontI
    FontUnderline = eFontU
    FontStrikethru = eFontK
   
End Sub

Public Sub pBullet(Optional ByVal LeftMargin As Single = -1)
  Dim eFontN As String
  Dim eFontB As Boolean
  Dim eFontI As Boolean
  Dim eFontU As Boolean
  Dim eFontK As Boolean
      
    If LeftMargin = -1 Then LeftMargin = CurrentX
    
    '/* Save current setting
    eFontN = FontName
    eFontB = FontBold
    eFontI = FontItalic
    eFontU = FontUnderline
    eFontK = FontStrikethru
    
    '/* Change settings
    'FontName = "Wingdings"
    FontName = "Symbol"
    FontBold = False
    FontItalic = False
    FontUnderline = False
    FontStrikethru = False
    
    'pPrint Chr(164) & "  ", LeftMargin, True
    pPrint Chr(183) & "  ", LeftMargin, True
    
    '/* Restore setting
    FontName = eFontN
    FontBold = eFontB
    FontItalic = eFontI
    FontUnderline = eFontU
    FontStrikethru = eFontK
   
End Sub

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

Public Sub pDots(ByVal RightMargin As Single, Optional ByVal LeftMargin As Single = 0)
    If LeftMargin > 0 Then CurrentX = LeftMargin
    If CurrentX >= RightMargin Then Exit Sub
    Do
        pPrint ".", , True
    Loop Until CurrentX >= RightMargin
End Sub

Public Function GetPage() As Variant
    If PrintFlag Then
       GetPage = Printer.Page
    Else
       GetPage = PageNumber + 1
    End If
End Function

Public Property Get SendToPrinter() As Boolean
    SendToPrinter = PrintFlag
End Property

Public Property Let SendToPrinter(ByVal vNewValue As Boolean)
    PrintFlag = vNewValue
End Property

Public Function GetPaperHeight() As Single
    GetPaperHeight = PgHeight
End Function
Public Function GetPaperWidth() As Single
    GetPaperWidth = PgWidth
End Function

Public Property Get CurrentX() As Single
    If PrintFlag Then
        CurrentX = Printer.CurrentX
    Else
        CurrentX = ObjPrint.CurrentX
    End If
End Property

Public Property Let CurrentX(ByVal NewXvalue As Single)
    If PrintFlag Then
        Printer.CurrentX = NewXvalue
    Else
        ObjPrint.CurrentX = NewXvalue
    End If
End Property

Public Property Get CurrentY() As Single
    If PrintFlag Then
        CurrentY = Printer.CurrentY
    Else
        CurrentY = ObjPrint.CurrentY
    End If
End Property

Public Property Let CurrentY(ByVal NewYvalue As Single)
    If PrintFlag Then
        Printer.CurrentY = NewYvalue
    Else
        ObjPrint.CurrentY = NewYvalue
    End If
End Property

Public Function GetStripQuotes(ByVal TextString As String) As String
    If Left(TextString, 1) = Chr(34) Then TextString = Mid(TextString, 2)
    If Right(TextString, 1) = Chr(34) Then TextString = Left(TextString, Len(TextString) - 1)
    GetStripQuotes = TextString
End Function

Public Property Get Orientation() As PageOrientation
    Orientation = oOrientation
End Property

Public Property Let Orientation(ByVal vNewValue As PageOrientation)
    Printer.Orientation = vNewValue
    oOrientation = vNewValue
End Property

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

Public Property Let DrawWidth(ByVal NewWidth As Integer)
    If NewWidth < 1 Then NewWidth = 1
    If PrintFlag Then
        Printer.DrawWidth = NewWidth
    Else
        NewWidth = NewWidth / 2
        If NewWidth < 1 Then NewWidth = 1
        ObjPrint.DrawWidth = NewWidth
    End If

End Property

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

Public Property Let BackColor(ByVal NewColor As Long)
  Dim r As Long
 
    If PrintFlag Then
        If NewColor = -1 Then
            Call MakeTrans '/* I am not sure why this is necessary
            r = SetBkColor(Printer.hdc, vbWhite)
            Printer.FontTransparent = True
        Else
            Printer.FontTransparent = False
            r = SetBkColor(Printer.hdc, NewColor)
        End If
    Else
        If NewColor = -1 Then
            ObjPrint.FontTransparent = True
            r = SetBkColor(ObjPrint.hdc, vbWhite)
        Else
            ObjPrint.FontTransparent = False
            r = SetBkColor(ObjPrint.hdc, NewColor)
        End If
    End If
    
End Property

Public Property Get FontName() As String
    If PrintFlag Then
        FontName = Printer.FontName
    Else
        FontName = ObjPrint.FontName
    End If
End Property

Public Property Let FontName(ByVal NewFont As String)
    If PrintFlag Then
        Printer.FontName = NewFont
        Printer.Print "";
    Else
        ObjPrint.FontName = NewFont
        ObjPrint.Print "";
    End If
End Property

Public Function GetTextWidth(TextString As Variant) As Single
    If PrintFlag Then
        GetTextWidth = Printer.TextWidth(TextString)
    Else
        GetTextWidth = ObjPrint.TextWidth(TextString)
    End If
End Function
Public Function GetTextHeight(Optional TextString As String = "Sample Text") As Single
    If PrintFlag Then
        GetTextHeight = Printer.TextHeight(TextString)
    Else
        GetTextHeight = ObjPrint.TextHeight(TextString)
    End If
End Function

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

Public Property Let FontTransparent(ByVal vNewValue As Boolean)
    If PrintFlag Then
        If vNewValue Then
            '/* I am not sure why this is necessary but it doesn't work without it
            Call MakeTrans
            BackColor = -1
        Else
            Printer.FontTransparent = False
        End If
    Else
        ObjPrint.FontTransparent = vNewValue
    End If
End Property

Private Sub MakeTrans()
  Dim x As Single, y As Single
    x = CurrentX
    y = CurrentY
    '/* I am not sure why this is necessary
    '/* but it doesn't work without it.
    Sleep 1
    BackColor = vbWhite
    Sleep 1
    pQuarterSpace
    Sleep 1
    CurrentX = x
    CurrentY = y
    Sleep 1

End Sub

Public Property Get ColorMode() As PrinterColorModeTypes
    ColorMode = oColorMode
End Property

Public Property Let ColorMode(ByVal vNewValue As PrinterColorModeTypes)
    oColorMode = vNewValue
    If PrintFlag Then Printer.ColorMode = vNewValue
End Property

Private Sub Class_Initialize()
    ColorMode = cmColor
    Orientation = PagePortrait
    PrintCopies = 1
    SendToPrinter = True
    
    '/* Default Scale Mode
    'vbInches or vbCentimeters
    oScaleMode = vbInches

End Sub