cmultipgpreview_jpg.cls

打印预览程序

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsMultiPgPreview"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'/*************************************/
'/* Author: Morgan Haueisen
'/*         [e-mail]
'/* Copyright (c) 1998-2003
'/*************************************/
'Legal:
'        This is intended for and was uploaded to www.planetsourcecode.com
'
'        Redistribution of this code, whole or in part, as source code or in binary form, alone or
'        as part of a larger distribution or product, is forbidden for any commercial or for-profit
'        use without the author's explicit written permission.
'
'        Redistribution of this code, as source code or in binary form, with or without
'        modification, is permitted provided that the following conditions are met:
'
'        Redistributions of source code must include this list of conditions, and the following
'        acknowledgment:
'
'        This code was developed by Morgan Haueisen.  <[e-mail]>
'        Source code, written in Visual Basic, is freely available for non-commercial,
'        non-profit use at www.planetsourcecode.com.
'
'        Redistributions in binary form, as part of a larger project, must include the above
'        acknowledgment in the end-user documentation.  Alternatively, the above acknowledgment
'        may appear in the software itself, if and wherever such third-party acknowledgments
'        normally appear.

Option Explicit

Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function GetBkColor Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'/* Flag indicating Printing or Previewing
Private PrintFlag As Boolean

'/* Object used for Print Preview
Private ObjPrint As Control

'/* Storage for the Printer's orignal scale mode
Private pSM As Integer
'/* Storage for the Object's orignal scale mode
Private oSM As Integer
'/* Default Scale Mode
Private oScaleMode As Integer

'/* The actual printable area (something a little less then the paper size)
Private PgWidth As Single
Private PgHeight As Single
Private oOrientation As Integer

'/* Remember ColorMode
Private oColorMode As Byte

'/* Remember Header Information
Private oTitleMain As String
Private oTitleSub As String
Private oTitleItalic As Boolean

Private PageNumber As Integer
Private TempDir As String

Public Enum PageOrientation
    PagePortrait = vbPRORPortrait
    PageLandscape = vbPRORLandscape
End Enum

Public Enum PrinterColorModeTypes
    cmMonochrome = vbPRCMMonochrome
    cmColor = vbPRCMColor
End Enum

'/* Rotate fonts
Private Const LF_FACESIZE = 32
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName As String * LF_FACESIZE
End Type

Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long ' or Boolean

Public Sub pPrintRotate(Optional ByVal PrintVar As String = vbNullString, _
                         Optional ByVal Degree As Integer = 0, _
                         Optional ByVal LeftMargin As Single = -1)
                       
'/* By Diomidis Kiriakopoulos modified by Me

    If PrintVar = vbNullString Then Exit Sub
    If Degree > 359 Then
        Degree = 359
    ElseIf Degree < 0 Then
        Degree = 0
    End If
    If LeftMargin = -1 Then
        LeftMargin = CurrentX
    Else
        CurrentX = LeftMargin
    End If
    
    On Local Error GoTo GetOut
    
    Dim F As LOGFONT, hPrevFont As Long, hFont As Long
    Dim ObjhDC As Long, x As Long, y As Long
    
    '/* Save the hDC.
    If PrintFlag Then
        Printer.Print "";
        ObjhDC = Printer.hdc
        F.lfHeight = (FontSize * -20) / Printer.TwipsPerPixelY
        x = Printer.CurrentX * 600
        y = Printer.CurrentY * 600
    Else
        ObjhDC = ObjPrint.hdc
        F.lfHeight = (FontSize * -20) / Screen.TwipsPerPixelY
    End If
        
    F.lfEscapement = 10 * Degree         '/* rotation angle, in tenths
    F.lfFaceName = FontName & vbNullChar '/* null terminated
    hFont = CreateFontIndirect(F)
    
    hPrevFont = SelectObject(ObjhDC, hFont)
  
    If PrintFlag Then
        '/* Draw the text.
        TextOut ObjhDC, x, y, PrintVar, Len(PrintVar)
    Else
        ObjPrint.Print PrintVar;
    End If
  
    '/*  Clean up, restore original font
    hFont = SelectObject(ObjhDC, hPrevFont)
    DeleteObject hFont
    
GetOut:
    On Local Error GoTo 0

End Sub

Public Sub pCenterMultiline(ByVal PrintVar As Variant, _
                      Optional ByVal LeftMargin As Single = 0, _
                      Optional ByVal RightMargin As Single = -1, _
                      Optional RemoveCrLf As Boolean = True, _
                      Optional SameLine As Boolean = False)
 
  Dim StartChar As Integer
  Dim CharLength As Single
  Dim CurrentPos As Single
  Dim TxtLen As Single
  Dim TxtWidth As Single
  Dim tString As String
  Dim NeedsStrip As Boolean
  Dim ColWidth As Single
  Dim x As Integer, y As Integer
 
    If RightMargin = -1 Then RightMargin = PgWidth
    ColWidth = RightMargin - LeftMargin
    
    TxtLen = Len(PrintVar)
    StartChar = 1
    CurrentPos = 0
    CharLength = TxtLen
 
    If PrintVar = vbNullString Then
        pPrint
        Exit Sub
    End If
    
    If InStr(PrintVar, vbCr) Or InStr(PrintVar, vbLf) Then NeedsStrip = True
    
    For x = 1 To TxtLen
        y = x - CurrentPos
        
        '/* Mark space between words
        If Mid(PrintVar, x, 1) < Chr(33) Then CharLength = y
        
        If (GetTextWidth(Mid(PrintVar, StartChar, y)) >= ColWidth) _
            Or (Not RemoveCrLf And Mid(PrintVar, x, 1) = vbCr) Then
           
            '/* If there are no spaces then break line here */
            If CharLength > y Then CharLength = y - 1
            
            tString = Trim(Mid(PrintVar, StartChar, CharLength))
            If NeedsStrip Then tString = GetRemoveCRLF(tString)
            CurrentX = LeftMargin + ((ColWidth - GetTextWidth(tString)) / 2)
            If PrintFlag Then
                Printer.Print tString
            Else
                ObjPrint.Print tString
            End If
            
            CurrentPos = CharLength + CurrentPos
            StartChar = CurrentPos + 1
            CharLength = TxtLen
           
        End If
    Next x

    tString = Trim(Mid(PrintVar, StartChar))
    If NeedsStrip Then tString = GetRemoveCRLF(tString)
    CurrentX = LeftMargin + ((ColWidth - GetTextWidth(tString)) / 2)
    If PrintFlag Then
        If SameLine Then
            Printer.Print tString;
        Else
            Printer.Print tString
        End If
    Else
        If SameLine Then
            ObjPrint.Print tString;
        Else
            ObjPrint.Print tString
        End If
    End If
    
End Sub


Public Property Let PrintCopies(pNumber As Integer)
    On Local Error Resume Next
    Printer.Copies = pNumber
    On Local Error GoTo 0
End Property

Public Property Get PrintCopies() As Integer
    On Local Error Resume Next
    PrintCopies = Printer.Copies
    On Local Error GoTo 0
End Property

Public Sub pCancled()
    FontSize = 12
    FontBold = True
    ForeColor = vbRed
    pPrint
    pPrint "**** PRINTING CANCLED ****", 0.5
End Sub

Public Sub pMultiline(ByVal PrintVar As Variant, _
                      Optional ByVal LeftMargin As Single = -1, _
                      Optional ByVal RightMargin As Single = -1, _
                      Optional ByVal IndentChar As String = vbNullString, _
                      Optional SameLine As Boolean = False, _
                      Optional UsePageBreaks As Boolean = True)
 
  Dim StartChar As Integer
  Dim SecondLine As Boolean
  Dim CharLength As Single
  Dim CurrentPos As Single
  Dim TxtLen As Single
  Dim TxtWidth As Single
  Dim IndentText As String
  Dim tString As String
  Dim NeedsStrip As Boolean
  Dim x As Integer, y As Integer
 
    If LeftMargin = -1 Then LeftMargin = CurrentX
    If LeftMargin > PgWidth - 0.1 Then LeftMargin = PgWidth - 0.5
    If RightMargin < LeftMargin Then RightMargin = PgWidth - 0.1
    RightMargin = RightMargin - LeftMargin
    
    If PrintVar = vbNullString Then
        If SameLine Then
            pPrint "", , True
        Else
            pPrint
        End If
        Exit Sub
    End If
    
    TxtLen = Len(PrintVar)
    StartChar = 1
    CurrentPos = 0
    CharLength = TxtLen
    IndentText = vbNullString
    
    If InStr(PrintVar, vbCr) Or InStr(PrintVar, vbLf) Then NeedsStrip = True
    
    For x = 1 To TxtLen
        y = x - CurrentPos
        If Mid(PrintVar, x, 1) < Chr(33) Then CharLength = y
        If (GetTextWidth(IndentText) + GetTextWidth(Mid(PrintVar, StartChar, y)) >= RightMargin) _
           Or (Mid(PrintVar, x, 1) = vbCr) Then
           
            '/* If there are no spaces then break line here */
            If CharLength > y Then CharLength = y - Len(IndentText) - 1
            If NeedsStrip Then
                tString = IndentText & Trim(GetRemoveCRLF(Mid(PrintVar, StartChar, CharLength)))
            Else
                tString = IndentText & Mid(PrintVar, StartChar, CharLength)
            End If
            
            CurrentX = LeftMargin
            If PrintFlag Then
                Printer.Print tString
            Else
                ObjPrint.Print tString
            End If
            
            CurrentPos = CharLength + CurrentPos
            StartChar = CurrentPos + 1
            CharLength = TxtLen
            If Not SecondLine Then
                SecondLine = True
                IndentText = IndentChar
            End If
            
            If UsePageBreaks Then
                If pEndOfPage Then
                    pFooter
                    pNewPage
                    pHeader
                End If
            End If
        End If
    Next x

    If NeedsStrip Then
        tString = IndentText & Trim(GetRemoveCRLF(Mid(PrintVar, StartChar)))
    Else
        tString = IndentText & Mid(PrintVar, StartChar)
    End If
    
    CurrentX = LeftMargin
    If SameLine Then
        If PrintFlag Then
            Printer.Print tString;
        Else
            ObjPrint.Print tString;
        End If
    Else
        If PrintFlag Then
            Printer.Print tString
        Else
            ObjPrint.Print tString
        End If
    End If
    
    
End Sub

Public Function GetRemoveCRLF(ByVal TextString As String) As String
  Dim i As Integer, FoundString As Boolean
  Dim FoundFirst As Boolean
  
    Do
        FoundString = False
        
        i = InStr(TextString, vbCr)
        If i Then
            Mid(TextString, i, 1) = " "
            FoundString = True
            FoundFirst = True
        End If
        
        i = InStr(TextString, vbLf)
        If i = 1 Then
            TextString = Mid(TextString, i + 1)
        ElseIf i > 1 Then
            If FoundFirst Then
                TextString = Mid(TextString, 1, i - 1) & Mid(TextString, i + 1)
            Else
                Mid(TextString, i, 1) = " "
            End If
            FoundString = True
        End If
        FoundFirst = False
        
    Loop Until FoundString = False
    GetRemoveCRLF = TextString
    
End Function

Public Sub pPrintPicture(NewPic As StdPicture, _
                        Optional LeftMargin As Single = -1, _
                        Optional TopMargin As Single = -1, _
                        Optional pWidth As Single = 0, _