?? cmultipgpreview.cls

?? 打印預覽程序
?? CLS
?? 第 1 頁 / 共 4 頁
字號:
                        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"
    
        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
?? 文件大小 325 K
?? 上傳用戶 lqlm521
?? 所屬分類其他
??? 相關標簽

#打印 #程序
?? 快捷鍵說明

復制代碼 Ctrl + C
搜索代碼 Ctrl + F
全屏模式 F11
切換主題 Ctrl + Shift + D
顯示快捷鍵 ?
增大字號 Ctrl + =
減小字號 Ctrl + -
亚洲欧美第一页_禁久久精品乱码_粉嫩av一区二区三区免费野_久草精品视频

?? cmultipgpreview.cls

?? 快捷鍵說明
