cmultipgpreview_withchart.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
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：05/05/13
'描  述：打印预览源码示例---MsChart
'网  站：http://www.mndsoft.com/
'e-mail：[e-mail]
'OICQ  : 88382850
'****************************************************************************'/*************************************/
'/*************************************/
'/* Author: Morgan Haueisen
'/*         [e-mail]
'/* Copyright (c) 1998-2002
'/*************************************/
'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 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

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 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 * 33
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

'/* Used by pChart to move chart to picturebox
Private Declare Function SendMessage Lib "user32" Alias _
      "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
      ByVal wParam As Long, ByVal lParam As Long) As Long

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

    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
      
    F.lfEscapement = 10 * Degree         '/* rotation angle, in tenths
    F.lfFacename = FontName & vbNullChar '/* null terminated
    F.lfHeight = (FontSize * -20) / Screen.TwipsPerPixelY
    hFont = CreateFontIndirect(F)
    
    If SameLine Then
        If PrintFlag Then
            hPrevFont = SelectObject(Printer.hdc, hFont)
            Printer.Print PrintVar;
        Else
            hPrevFont = SelectObject(ObjPrint.hdc, hFont)
            ObjPrint.Print PrintVar;
        End If
    Else
        If PrintFlag Then
            hPrevFont = SelectObject(Printer.hdc, hFont)
            Printer.Print PrintVar
        Else
            hPrevFont = SelectObject(ObjPrint.hdc, hFont)
            ObjPrint.Print PrintVar
        End If
    End If
    
    '/*  Clean up, restore original font
    If PrintFlag Then
        hFont = SelectObject(Printer.hdc, hPrevFont)
    Else
        hFont = SelectObject(ObjPrint.hdc, hPrevFont)
    End If
    
    DeleteObject hFont
    
GetOut:
    On Local Error GoTo 0

End Sub

Public Sub pChart(sWide As Single, sTall As Single, Optional LeftMargin As Single = -1, _
                        Optional TopMargin As Single = -1, _
                        Optional pWidth As Single = 0, _
                        Optional pHeight As Single = 0, _
                        Optional ScaleToFit As Boolean = False, _
                        Optional MaintainRatio As Boolean = True)
                        
  '/* Submitted by Jim Steele */
  
  '/* Required to move the chart to a picturebox
  '/*      Private Declare Function SendMessage Lib "user32" Alias _
               "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
               ByVal wParam As Long, ByVal lParam As Long) As Long

  
  Const twipFactor As Long = 1440
  Const WM_PAINT = &HF
    
    With frmMultiPgPreview.Chart1
        .Top = 0
        .Left = 0
        .Width = twipFactor * sWide
        .Height = twipFactor * sTall
    End With
    
    frmMultiPgPreview.PictChart.ScaleMode = vbTwips
    frmMultiPgPreview.PictChart.AutoRedraw = True
    frmMultiPgPreview.PictChart.Height = frmMultiPgPreview.Chart1.Height
    frmMultiPgPreview.PictChart.Width = frmMultiPgPreview.Chart1.Width

    SendMessage frmMultiPgPreview.Chart1.hwnd, WM_PAINT, frmMultiPgPreview.PictChart.hdc, 0
    frmMultiPgPreview.PictChart.Picture = frmMultiPgPreview.PictChart.Image
    
    '/* Print/Preview Picture
    cPrint.pPrintPicture frmMultiPgPreview.PictChart.Picture, LeftMargin, TopMargin, pWidth, pHeight, ScaleToFit, MaintainRatio
    
    frmMultiPgPreview.PictChart.Picture = Nothing
 
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 = False)
 
  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
    
    TxtLen = Len(PrintVar)
    StartChar = 1
    CurrentPos = 0
    CharLength = TxtLen
    IndentText = vbNullString
 
    If PrintVar = vbNullString Then
        If SameLine Then
            pPrint "", , True
        Else
            pPrint
        End If
        Exit Sub
    End If
    
    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
                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