preview.cls

VB做的报表设计源程序,非常不错,可以自定义模版

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Preview"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Attribute VB_Ext_KEY = "Member0" ,"Pages"
'////////////////////////////////////////////////////////
'///                 Print Preview Class
'///                   (clsPreview.cls)
'///_____________________________________________________
'/// Print Preview class with Navigation Bar.
'///_____________________________________________________
'/// Last modification  : Ago/09/2000
'/// Last modified by   : Leontti R.
'/// Modification reason: Created
'/// Project: RamoSoft Component Suite ' I borrowed this code from a another project from myself
'/// Author: Leontti A. Ramos M. ([e-mail])
'/// RamoSoft de Mexico S.A. de C.V.
'////////////////////////////////////////////////////////
Option Explicit

Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CopyRect Lib "user32" (lpDestRect As RECT, lpSourceRect As RECT) As Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
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
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Const WM_SETREDRAW = &HB

Private m_oMemDC As clsMemDC
Private m_oImgLst As clsImageList

Private WithEvents m_oForm As frmPreview
Attribute m_oForm.VB_VarHelpID = -1
Private WithEvents m_oViewPort As PictureBox
Attribute m_oViewPort.VB_VarHelpID = -1
Private WithEvents m_oPreview As PictureBox
Attribute m_oPreview.VB_VarHelpID = -1
Private WithEvents m_oPage As PictureBox
Attribute m_oPage.VB_VarHelpID = -1
Private WithEvents m_oPages As Pages
Attribute m_oPages.VB_VarHelpID = -1
Private WithEvents m_oPageBack As PictureBox
Attribute m_oPageBack.VB_VarHelpID = -1

Private LnTPPX As Integer
Private m_iLastButton As ButtonIndex
Private m_iButtonCount As Integer
Private m_lOldParent As Long
Private m_lPageWidth As Long
Private m_lPageHeight As Long
Private m_iPageSize As Integer
Private m_lContainer As Long
Private m_iZoomLevel As ZoomRatio
Private m_bDragging As Boolean
Private m_rDragPos As POINTAPI
Private m_bLockRedraw As Boolean
Private m_bLockWndRedraw As Boolean
Private m_lPage As Long

Private Const PN_BUTTON_SIDE = 24

Private Type ButtonInfo
    ImageIdx As Integer
    Left As Long
    Rigth As Long
    Enabled As Boolean
    Caption As String
    ToolTipText As String
    Key As String
    IsSeparator As Boolean
End Type

Private Buttons() As ButtonInfo

Private Enum ButtonIndex
    [No Button] = 0
    PageFirst
    PagePrevious
    PageGoto
    PageNext
    PageLast
    [Sep 1]
    [Print Pages]
    [Sep 2]
    ZoomPreview
    [Sep 3]
    PreviewTools
    CustomCommand
    [Sep 4]
    ClosePreview
End Enum

Private Enum ZoomRatio
    [100%] = 0
    [75%]
    [50%]
    [25%]
    [Page Width]
    [Full Page]
    [Custom Ratio]
    [Hide Page]
End Enum

Private Enum CursorResource
    HandOpen = 101
    HandClosed = 102
    HandClosedArrows = 103
    HandClosedUpDown = 104
    HandClosedLeftRight = 105
End Enum

Public Event UserCommand()
Public Event Printing()
Public Event Done(iFormat As ARDestination)

Public OutputFile As String
Public LaunchFile As Boolean

' Temp filke related
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH = 260
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long

Public Sub AboutBox()
    frmAbout.Start
End Sub

Public Property Get LockRedraw() As Boolean
    LockRedraw = m_bLockRedraw
End Property

Public Property Let LockRedraw(bLock As Boolean)
    If (m_bLockRedraw <> bLock) Then
        If m_bLockRedraw Then
            Redraw
        Else
            m_bLockRedraw = bLock
        End If
    End If
End Property


Public Sub Redraw()
    m_bLockRedraw = False
    If m_bLockWndRedraw Then
        LockWindowUpdate 0
        m_bLockWndRedraw = False
    Else
        prvBuildPageImage
    End If
End Sub


Friend Sub ShowPageSelection(sSelection As String)
    m_oForm.lblRange = sSelection
End Sub

Public Function SyncShell(sCmdLine As String) As Long
    Dim lR As Long
    On Error Resume Next
    lR = ShellExecute(0&, "Open", sCmdLine, "", "", vbNormalFocus)
End Function

Private Function GetTempFile(Optional Prefix As String) As String
'    Dim PathName As String
'    Dim sRet As String
'
'    If Prefix = "" Then Prefix = ""
'    PathName = GetTempDir
'    sRet = String(MAX_PATH, 0)
'    GetTempFileName PathName, Prefix, 0, sRet
'    GetTempFile = StrZToStr(sRet)

    Dim PathName As String

    If Prefix = "" Then Prefix = "ARExp"
    PathName = GetTempDir
    If (Right(PathName, 1) <> "\") Then PathName = PathName & "\"
    GetTempFile = PathName & Prefix & Hex(Timer) & ".tmp"
End Function

Private Function GetTempDir() As String
    Dim sRet As String
    Dim c As Long
    sRet = String(MAX_PATH, 0)
    c = GetTempPath(MAX_PATH, sRet)
    If c = 0 Then
        GetTempDir = App.Path
    Else
        GetTempDir = Left$(sRet, c)
    End If
End Function


Public Sub Cls()
    m_oMemDC.Cls
End Sub

Public Property Get Pages() As Pages
    Set Pages = m_oPages
End Property

Private Sub prvDisableButtons()
    Dim LnIdx As Integer
    For LnIdx = PageFirst To ZoomPreview
        Buttons(LnIdx).Enabled = False
    Next
    If (Not m_bLockRedraw) Then prvDrawToolbar
End Sub

Private Sub prvEnableButtons()
    Dim LnIdx As Integer
    
    With m_oPages
        Buttons(PageFirst).Enabled = .TestEnable(PageFirst)
        Buttons(PagePrevious).Enabled = .TestEnable(PagePrevious)
        Buttons(PageGoto).Enabled = .TestEnable(PageGoto)
        Buttons(PageNext).Enabled = .TestEnable(PageNext)
        Buttons(PageLast).Enabled = .TestEnable(PageLast)
    End With
     Buttons([Print Pages]).Enabled = (Printers.Count > 0)
'    For LnIdx = PrintPages To ZoomPreview
'        Buttons(LnIdx).Enabled = True
'    Next
     Buttons(ZoomPreview).Enabled = True
    prvDrawToolbar
End Sub

Private Sub prvLoadForm()
    Load frmPreview
    Set m_oForm = frmPreview
    m_lContainer = m_oForm.hWnd
    Set m_oViewPort = m_oForm.picViewPort
    Set m_oPreview = m_oForm.picPreview
    Set m_oPage = m_oForm.picPage
    Set m_oPageBack = m_oForm.picBack
    
End Sub

Private Sub prvBuildPageImage()
    If m_bLockRedraw Then Exit Sub
    Dim LnIdx As Integer
    Dim LbRebuildDC As Boolean
    
    With Pages.ActivePage
        m_lPageWidth = .DisplayWidth
        m_lPageHeight = .DisplayHeight
    End With
    With m_oMemDC
        LbRebuildDC = ((.Width <> m_lPageWidth) Or (.Height <> m_lPageHeight))
        If LbRebuildDC Then
            .Create m_lPageWidth, m_lPageHeight
        Else
            .Cls
        End If
    End With
    With Pages.ActivePage
        For LnIdx = 1 To .Count
            With .Element(LnIdx)
                Select Case .Type
                    Case 1 ' Text
                        Dim LhOldFont As Long
                        
                        LhOldFont = SelectObject(m_oMemDC.hDC, Pages.FontMap.Item(.FontIndex).Handle)
                        m_oMemDC.DrawText .Text, .Left, .Top, .Width, .Height, .ForeColor, .BackColor, .Aligment
                        LhOldFont = SelectObject(m_oMemDC.hDC, LhOldFont)
                    Case 2 ' Line
                        m_oMemDC.DrawLine .Left, .Top, .Width, .Height, .ForeColor, CLng(.Size), .Pen
                    Case 3 ' Box
                        m_oMemDC.DrawShape .DisplayType, .Left, .Top, .Width, .Height, CInt(.Size), .ForeColor, .BackColor, .Pen
                    Case 4 ' Picture
                        On Error Resume Next
                        m_oMemDC.DrawPicture .Picture, .Left, .Top, .Width, .Height
                    Case 5 ' Checkbox
                        m_oMemDC.DrawCheckBox .DisplayType, .Checked, .Left, .Top, .Width, .Height, .ForeColor, .BackColor, CLng(.Size), .Sunken
                End Select
            End With
        Next
    End With
    If LbRebuildDC Then
        prvSetZoomRatio m_iZoomLevel
    Else
        With m_oPage
            .Visible = True
            m_oMemDC.BlitImage .hDC, 0, 0, .ScaleWidth, .ScaleHeight, Pages.ActivePage.Enabled
        End With
    End If
End Sub

Private Sub prvUnloadForm()
    ' Returns to original container
    Container = m_oForm.hWnd
    m_lContainer = 0
    ' Remove controls references
    Set m_oViewPort = Nothing
    Set m_oPreview = Nothing
    ' Unload support form
    Set m_oForm = Nothing
    Unload frmPreview
End Sub

Friend Sub RaiseErr(ByVal lErrNum As RSErrorCode, Optional sRoutineName As String, _
    Optional sDescription As String)
    RaiseError lErrNum, TypeName(Me), sRoutineName, sDescription, Erl
End Sub