cmultipgpreview_jpg.cls

打印预览程序

                        Optional pHeight As Single = 0, _
                        Optional ScaleToFit As Boolean = False, _
                        Optional MaintainRatio As Boolean = True)
 
  Dim xmin As Single
  Dim ymin As Single
  Dim wid As Single
  Dim hgt As Single
  Dim aspect As Single
  Dim picBox As PictureBox
 
    If pWidth = 0 Then pWidth = pHeight
    If pHeight = 0 Then pHeight = pWidth
    If pWidth = 0 And pHeight = 0 Then ScaleToFit = True
    
    If PrintFlag Then
        Load frmMultiPgPreview
        Set picBox = frmMultiPgPreview.picPrintPic
        picBox.Picture = NewPic
        
        aspect = picBox.ScaleHeight / picBox.ScaleWidth
        If ScaleToFit Then
            wid = Printer.ScaleWidth
            hgt = Printer.ScaleHeight
        Else
            wid = pWidth
            hgt = pHeight
        End If
        
        If MaintainRatio Then
            If hgt / wid > aspect Then
                hgt = aspect * wid
                If LeftMargin = -1 Then
                    xmin = Printer.ScaleLeft
                Else
                    xmin = LeftMargin
                End If
                If TopMargin = -1 Then
                    ymin = (Printer.ScaleHeight - hgt) / 2
                Else
                    ymin = TopMargin
                End If
            Else
                wid = hgt / aspect
                If LeftMargin = -1 Then
                    xmin = (Printer.ScaleWidth - wid) / 2
                Else
                    xmin = LeftMargin
                End If
                If TopMargin = -1 Then
                    ymin = Printer.ScaleTop
                Else
                    ymin = TopMargin
                End If
            End If
        Else
            If LeftMargin = -1 Then
                xmin = Printer.ScaleLeft
            Else
                xmin = LeftMargin
            End If
            If TopMargin = -1 Then
                ymin = (Printer.ScaleHeight - hgt) / 2
            Else
                ymin = TopMargin
            End If
        End If
        
        Printer.PaintPicture picBox.Picture, xmin, ymin, wid, hgt, , , , , vbSrcCopy
        Unload frmMultiPgPreview
        
    Else
        
        Set picBox = frmMultiPgPreview.picPrintPic
        picBox.Picture = NewPic
        
        aspect = picBox.ScaleHeight / picBox.ScaleWidth
        If ScaleToFit Then
            wid = ObjPrint.ScaleWidth
            hgt = ObjPrint.ScaleHeight
        Else
            wid = pWidth
            hgt = pHeight
        End If
        
        If MaintainRatio Then
            If hgt / wid > aspect Then
                hgt = aspect * wid
                If LeftMargin = -1 Then
                    xmin = ObjPrint.ScaleLeft
                Else
                    xmin = LeftMargin
                End If
                If TopMargin = -1 Then
                    ymin = (ObjPrint.ScaleHeight - hgt) / 2
                Else
                    ymin = TopMargin
                End If
            Else
                wid = hgt / aspect
                If LeftMargin = -1 Then
                    xmin = (ObjPrint.ScaleWidth - wid) / 2
                Else
                    xmin = LeftMargin
                End If
                If TopMargin = -1 Then
                    ymin = ObjPrint.ScaleTop
                Else
                    ymin = TopMargin
                End If
            End If
        Else
            If LeftMargin = -1 Then
                xmin = ObjPrint.ScaleLeft
            Else
                xmin = LeftMargin
            End If
            If TopMargin = -1 Then
                ymin = (ObjPrint.ScaleHeight - hgt) / 2
            Else
                ymin = TopMargin
            End If
        End If
        
        ObjPrint.PaintPicture picBox.Picture, xmin, ymin, wid, hgt, , , , , vbSrcCopy
        
        picBox.Picture = Nothing
        
    End If
    
    Set picBox = Nothing
    
End Sub

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

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

Public Function GetFormalCase(ByVal TextString As String) As String
  Dim x As Integer
 
    '/* Cap the first letter if each word
    On Local Error Resume Next
    
    TextString = UCase$(left$(TextString, 1)) & LCase$(Mid$(TextString, 2))
    
    '/* Look for space
    x = InStr(TextString, " ")
    If x Then
        Do
            Mid$(TextString, x + 1, 1) = UCase$(Mid$(TextString, x + 1, 1))
            x = x + 1
            x = InStr(x, TextString, " ")
            If x = 0 Or x + 1 > Len(TextString) Then Exit Do
        Loop
    End If
    
    '/* Look for .
    x = InStr(TextString, ".")
    If x Then
        Do
            Mid$(TextString, x + 1, 1) = UCase$(Mid$(TextString, x + 1, 1))
            x = x + 1
            x = InStr(x, TextString, ".")
            If x = 0 Or x + 1 > Len(TextString) Then Exit Do
        Loop
    End If
    
    '/* Look for Mc
    x = InStr(TextString, "Mc")
    If x Then
        Do
            Mid$(TextString, x + 2, 1) = UCase$(Mid$(TextString, x + 2, 1))
            x = x + 2
            x = InStr(x, TextString, "Mc")
            If x = 0 Or x + 2 > Len(TextString) Then Exit Do
        Loop
    End If
    
    '/* Look for O'
    x = InStr(TextString, "O'")
    If x Then
        Do
            Mid$(TextString, x + 2, 1) = UCase$(Mid$(TextString, x + 2, 1))
            x = x + 2
            x = InStr(x, TextString, "O'")
            If x = 0 Or x + 2 > Len(TextString) Then Exit Do
        Loop
    End If
    
    '/* Look for -
    x = InStr(TextString, "-")
    If x Then
       Do
           Mid$(TextString, x + 1, 1) = UCase$(Mid$(TextString, x + 1, 1))
           x = x + 1
           x = InStr(x, TextString, "-")
           If x = 0 Or x + 1 > Len(TextString) Then Exit Do
       Loop
    End If
    
    GetFormalCase = LTrim$(TextString)
 
End Function

Public Sub pRightTab(ByVal PrintVar As Variant, _
                            Optional ByVal xFromRight As Single = 0.1, _
                            Optional SameLine As Boolean = False)
 
    CurrentX = PgWidth - (GetTextWidth(PrintVar) + xFromRight)
    
    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 pCenter(ByVal PrintVar As String, _
                   Optional SameLine As Boolean = False, _
                   Optional ColWidth As Single = -1, _
                   Optional LeftMargin As Single = 0)
        
    If ColWidth = -1 Then ColWidth = PgWidth - LeftMargin
    
    If GetTextWidth(PrintVar) > PgWidth Then
        pCenterMultiline PrintVar, LeftMargin, LeftMargin + ColWidth, , SameLine
    Else
        CurrentX = LeftMargin + ((ColWidth - GetTextWidth(PrintVar)) / 2)
        pPrint PrintVar, , SameLine
    End If
    
End Sub

Public Sub pRightJust(ByVal PrintVar As Variant, _
                      Optional ByVal RightMargin As Single = -1, _
                      Optional SameLine As Boolean = False)
  
  Dim TxtWidth As Single
  
    TxtWidth = GetTextWidth(PrintVar)
    If RightMargin = -1 Then RightMargin = CurrentX + TxtWidth
    CurrentX = RightMargin - TxtWidth
    
    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 pBox(Optional ByVal bLeft As Single = -1, _
                Optional ByVal bTop As Single = -1, _
                Optional ByVal bWidth As Single = -1, _
                Optional ByVal bHeight As Single = -1, _
                Optional ByVal ColorLine As Long = -1, _
                Optional ByVal ColorFill As Long = -1, _
                Optional FilledBox As FillStyleConstants = vbFSTransparent)
   
  Dim x As Single, y As Single
  
    y = CurrentY
    x = CurrentX
    
    If ColorLine = -1 Then ColorLine = ForeColor
    If ColorFill = -1 Then ColorFill = ColorLine
    If bLeft = -1 Then bLeft = CurrentX
    If bTop = -1 Then bTop = CurrentY
    If bWidth = -1 Then bWidth = PgWidth
    If bHeight = -1 Then bHeight = GetTextHeight
    
    If FilledBox <> vbFSTransparent Then
        If PrintFlag Then
            Printer.FillColor = ColorFill
            Printer.FillStyle = FilledBox
            Printer.Line (bLeft, bTop)-(bLeft + bWidth, bTop + bHeight), ColorLine, B
            Printer.FillStyle = vbFSTransparent
        Else
            ObjPrint.FillColor = ColorFill
            ObjPrint.FillStyle = FilledBox
            ObjPrint.Line (bLeft, bTop)-(bLeft + bWidth, bTop + bHeight), ColorLine, B
            ObjPrint.FillStyle = vbFSTransparent
        End If
    Else
        If PrintFlag Then
            Printer.FillStyle = vbFSTransparent
            Printer.Line (bLeft, bTop)-(bLeft + bWidth, bTop + bHeight), ColorLine, B
        Else
            ObjPrint.FillStyle = vbFSTransparent
            ObjPrint.Line (bLeft, bTop)-(bLeft + bWidth, bTop + bHeight), ColorLine, B
        End If
    End If
    
    CurrentX = x
    CurrentY = y
    
End Sub

Public Sub pCircle(ByVal bLeft As Single, _
                   ByVal bTop As Single, _
                   ByVal bRadius As Single, _
                   Optional ByVal ColorLine As Long = -1, _
                   Optional ByVal ColorFill As Long = -1, _
                   Optional FilledCircle As FillStyleConstants = vbFSTransparent, _
                   Optional AspectRatio As Single = 1)
                   
    If ColorLine = -1 Then ColorLine = ForeColor
    If ColorFill = -1 Then ColorFill = ColorLine
    
    If PrintFlag Then
        If FilledCircle <> vbFSTransparent Then
            Printer.FillStyle = FilledCircle
            Printer.FillColor = ColorFill
        End If
        
        Printer.Circle (bLeft, bTop), bRadius, ColorLine, , , AspectRatio
        
        Printer.FillStyle = vbFSTransparent
    Else
        If FilledCircle <> vbFSTransparent Then
            ObjPrint.FillStyle = FilledCircle
            ObjPrint.FillColor = ColorFill
        End If
        
        ObjPrint.Circle (bLeft, bTop), bRadius, ColorLine, , , AspectRatio
        
        ObjPrint.FillStyle = vbFSTransparent
    End If
    
End Sub

Public Sub pEndDoc(Optional ByVal oModal As Byte = 1, Optional OwnerForm As Form)
  Dim i As Integer
    
    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"
        ObjPrint.Picture = ObjPrint.Image
        SavePictureAsJPG ObjPrint, TempDir & "PPview" & CStr(PageNumber) & ".JPG"
    
        frmMultiPgPreview.PageNumber = PageNumber
        frmMultiPgPreview.Picture1.Picture = LoadPicture(TempDir & "PPview" & CStr(0) & ".JPG")
        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