frmmultipgpreview_jpg.frm

打印预览程序

         Top             =   30
         Width           =   3090
      End
      Begin VB.Label optText 
         BackStyle       =   0  'Transparent
         Caption         =   "Print Pages"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H80000014&
         Height          =   300
         Index           =   2
         Left            =   585
         TabIndex        =   6
         Top             =   1365
         Width           =   1965
      End
   End
   Begin VB.PictureBox Picture1 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H00FFFFFF&
      BeginProperty Font 
         Name            =   "Times New Roman"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000008&
      Height          =   4845
      Left            =   0
      ScaleHeight     =   321
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   249
      TabIndex        =   0
      TabStop         =   0   'False
      Top             =   0
      Width           =   3765
   End
   Begin VB.PictureBox picGetFolder 
      Appearance      =   0  'Flat
      ForeColor       =   &H80000008&
      Height          =   4440
      Left            =   1245
      ScaleHeight     =   4410
      ScaleWidth      =   6375
      TabIndex        =   20
      Top             =   615
      Visible         =   0   'False
      Width           =   6405
      Begin VB.DriveListBox Drive1 
         Height          =   315
         Left            =   1530
         TabIndex        =   26
         Top             =   45
         Width           =   3930
      End
      Begin VB.DirListBox Dir1 
         Height          =   3465
         Left            =   30
         TabIndex        =   25
         Top             =   450
         Width           =   6315
      End
      Begin VB.CommandButton cmdNewFolder 
         Height          =   345
         Left            =   5955
         MaskColor       =   &H00FFFFFF&
         Picture         =   "FRMMUL~1.frx":1F1D
         Style           =   1  'Graphical
         TabIndex        =   24
         ToolTipText     =   "New Folder"
         Top             =   30
         UseMaskColor    =   -1  'True
         Width           =   375
      End
      Begin VB.CommandButton cmdUpOne 
         Height          =   345
         Left            =   5520
         MaskColor       =   &H00FFFFFF&
         Picture         =   "FRMMUL~1.frx":226B
         Style           =   1  'Graphical
         TabIndex        =   23
         ToolTipText     =   "Back Up"
         Top             =   30
         UseMaskColor    =   -1  'True
         Width           =   375
      End
      Begin VB.CommandButton cmdOpen 
         Caption         =   "Ok"
         Height          =   375
         Left            =   4830
         TabIndex        =   22
         Top             =   3975
         Width           =   1470
      End
      Begin VB.CommandButton cmdQuit 
         Caption         =   "Cancel"
         Height          =   375
         Left            =   3255
         TabIndex        =   21
         Top             =   3975
         Width           =   1470
      End
      Begin VB.Label Label4 
         AutoSize        =   -1  'True
         Caption         =   " Select a Directory: "
         Height          =   195
         Left            =   75
         TabIndex        =   27
         Top             =   90
         Width           =   1395
      End
   End
   Begin VB.Image imgFit 
      Height          =   240
      Index           =   0
      Left            =   60
      Picture         =   "FRMMUL~1.frx":251D
      Top             =   5145
      Visible         =   0   'False
      Width           =   240
   End
   Begin VB.Image imgFit 
      Height          =   240
      Index           =   1
      Left            =   420
      Picture         =   "FRMMUL~1.frx":2AA7
      Top             =   5160
      Visible         =   0   'False
      Width           =   240
   End
   Begin VB.Image optArt 
      Appearance      =   0  'Flat
      Height          =   225
      Index           =   1
      Left            =   0
      Picture         =   "FRMMUL~1.frx":3031
      Top             =   4860
      Visible         =   0   'False
      Width           =   300
   End
   Begin VB.Image optArt 
      Appearance      =   0  'Flat
      Height          =   225
      Index           =   0
      Left            =   555
      Picture         =   "FRMMUL~1.frx":30DE
      Top             =   4875
      Visible         =   0   'False
      Width           =   300
   End
End
Attribute VB_Name = "frmMultiPgPreview"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'/*************************************/
'/* Author: Morgan Haueisen
'/*         [e-mail]
'/* Copyright (c) 1999-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

'/* Used for Manifest files (Win XP)
Private Declare Function InitCommonControls Lib "Comctl32.dll" () As Long

Public PageNumber As Integer
Private ViewPage As Integer
Private TempDir As String
Private OptionV As Integer
Private FitToPage As Boolean

Private Type PanState
   x As Long
   y As Long
End Type
Dim PanSet As PanState

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 GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
    (lpVersionInformation As OSVersionInfo) As Long

Private Declare Function CreateDirectory Lib "kernel32.dll" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type

Private Type OSVersionInfo
    OSVSize As Long
    dwVerMajor As Long
    dwVerMinor As Long
    dwBuildNumber As Long
    PlatformID As Long
    szCSDVersion As String * 128
End Type
Private UseStretchBit As Boolean

Private Sub cmd_print_Click()
    picGoto.Visible = False
    
    txtTo.Text = PageNumber + 1
    OptionV = 3
    Call optText_Click(OptionV)
    
    picPrintOptions.Left = Me.Width - (Picture2.Width + picPrintOptions.Width + 50)
    picPrintOptions.Top = cmd_print.Top
    picPrintOptions.ZOrder
    
    picGetFolder.Left = Me.Width - (Picture2.Width + picGetFolder.Width + 50)
    picGetFolder.Top = cmd_print.Top
    
    picPrintOptions.Visible = True
End Sub

Private Function IsNumber(ByVal CheckString As String, Optional KeyAscii As Integer = 0, Optional AllowDecPoint As Boolean = False, Optional AllowNegative As Boolean = False) As Boolean
    If KeyAscii > 0 And KeyAscii <> 8 Then
        If Not AllowNegative And KeyAscii = 45 Then KeyAscii = 0
        If Not AllowDecPoint And KeyAscii = 46 Then KeyAscii = 0
        If Not IsNumeric(CheckString & Chr(KeyAscii)) Then
            KeyAscii = False
            IsNumber = False
        Else
            IsNumber = True
        End If
    Else
        IsNumber = IsNumeric(CheckString)
    End If
End Function

Private Sub cmd_quit_Click()
    cPrint.SendToPrinter = False
    Unload Me
End Sub

Private Sub cmdFullPage_Click()
  Dim xmin As Single
  Dim ymin As Single
  Dim wid As Single
  Dim hgt As Single
  Dim aspect As Single
 
    '/* If already here then restore original
    If cmdFullPage.Value = 0 Then
        Picture1.Visible = True
        Picture1.SetFocus
        picFullPage.Visible = False
        cmdFullPage.Picture = imgFit(0).Picture
        Exit Sub
    End If
    
    Screen.MousePointer = vbHourglass
    DoEvents
    cmdFullPage.Picture = imgFit(1).Picture
    
    '/* Clear any picture and set the size and loaction
    Set picFullPage.Picture = Nothing
    If Not picHScroll.Visible Then
        picFullPage.Height = Me.Height - 100
        picFullPage.Width = picFullPage.Height * 0.773
        picFullPage.Move ((Me.Width - Picture2.Width) - picFullPage.Width) \ 2, 0
    Else
        picFullPage.Top = 50
        picFullPage.Left = 50
        picFullPage.Width = Me.Width - Picture2.Width - 100
        picFullPage.Height = picFullPage.Width * 0.773
    End If
        
    '/* Get the scale values
    aspect = Picture1.ScaleHeight / Picture1.ScaleWidth
    wid = picFullPage.ScaleWidth
    hgt = picFullPage.ScaleHeight
    
    '/* MaintainRatio
    If hgt / wid > aspect Then
        hgt = aspect * wid
        xmin = picFullPage.ScaleLeft
        ymin = (picFullPage.ScaleHeight - hgt) / 2
    Else
        wid = hgt / aspect
        xmin = (picFullPage.ScaleWidth - wid) / 2
        ymin = picFullPage.ScaleTop
    End If
    
    If UseStretchBit Then '/* NT platform
        StretchBlt picFullPage.hdc, _
            xmin, ymin, wid, hgt, _
            Picture1.hdc, _
            0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, vbSrcCopy
    Else
        picFullPage.PaintPicture Picture1.Picture, _
          xmin, ymin, wid, hgt, _
          0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, vbSrcCopy
    End If

    picGoto.Visible = False
    Picture1.Visible = False
    picFullPage.Visible = True
    picFullPage.SetFocus
    
    Screen.MousePointer = vbDefault
    
End Sub

Private Sub cmdGoTo_Click()
    picGoto.Top = cmdGoTo.Top
    picGoto.Left = Me.Width - (Picture2.Width + picGoto.Width + 50)
    picGoto.Visible = True
    picGoto.ZOrder
    txtGoto = CStr(ViewPage + 1)
    txtGoto.SelStart = 0
    txtGoto.SelLength = Len(txtGoto)
    txtGoto.SetFocus
End Sub

Private Sub cmdGotoOK_Click()
  Dim NewPageNo As Integer
    
    On Local Error Resume Next
    
    txtGoto.SetFocus
    NewPageNo = Val(txtGoto)
    If NewPageNo = 0 Then Exit Sub
    
    NewPageNo = NewPageNo - 1
    If NewPageNo > PageNumber Then NewPageNo = PageNumber
    ViewPage = NewPageNo
        
    Picture1.SetFocus
    Picture1.Picture = LoadPicture(TempDir & "PPview" & CStr(ViewPage) & ".JPG")
    
    picPrintOptions.Visible = False
    picGetFolder.Visible = False
    picGoto.Visible = False
    
    VScroll1.Value = 0
    HScroll1.Value = 0
    Call DisplayPages

End Sub

Private Sub cmdPrint_Click()
  Dim i As Integer
  
    '/* Prevent printing again until done
    picPrintOptions.Enabled = False
    lblPrintingPg.Visible = True
    cmdPrint.Visible = False
    
    Select Case OptionV
    Case 0 '/* Copy to clipboard
        Clipboard.Clear
        Clipboard.SetData Picture1.Picture, vbCFBitmap
    Case 1 '/* Print current page
        lblPrintingPg.Caption = "Printing page " & ViewPage + 1
        lblPrintingPg.Refresh
        Call PrintPictureBox(Picture1, True, False)
    Case 2 '/* Print range
        For i = Val(txtFrom) - 1 To Val(txtTo) - 1
            lblPrintingPg.Caption = "Printing page " & CStr(i + 1) & " of " & txtTo
            lblPrintingPg.Refresh
            Picture1.Picture = LoadPicture(TempDir & "PPview" & CStr(i) & ".JPG")
            Call PrintPictureBox(Picture1, True, False)
        Next i
        Picture1.Picture = LoadPicture(TempDir & "PPview" & CStr(ViewPage) & ".JPG")
    Case 4
        picGetFolder.Visible = True
        picGetFolder.ZOrder
    Case Else '/* Print all
        cPrint.SendToPrinter = True '/* Send to Printer */
        Unload Me
    End Select
    
    '/* Restore normal view
    picPrintOptions.Enabled = True
    cmdPrint.Visible = True
    picPrintOptions.Visible = False
    lblPrintingPg.Visible = False
    
End Sub

Private Sub Command1_Click(Index As Integer)
    On Local Error Resume Next
    If Index = 0 Then
        ViewPage = ViewPage - 1
        If ViewPage < 0 Then ViewPage = 0
        Picture1.Picture = LoadPicture(TempDir & "PPview" & CStr(ViewPage) & ".JPG")
    Else
        ViewPage = ViewPage + 1
        If ViewPage > PageNumber Then ViewPage = PageNumber
        Picture1.Picture = LoadPicture(TempDir & "PPview" & CStr(ViewPage) & ".JPG")
    End If
    
    Picture1.Top = 0
    picPrintOptions.Visible = False
    picGoto.Visible = False
    VScroll1.Value = 0
    HScroll1.Value = 0
    Call DisplayPages
    
End Sub

Private Sub Form_Activate()
    Screen.MousePointer = vbDefault
    Call DisplayPages
    If Picture1.Width < Me.Width - Picture2.Width Then
        Picture1.Move ((Me.Width - Picture2.Width) - Picture1.Width) \ 2, 0
    End If
    cmdFullPage.Picture = imgFit(0).Picture
    Label5 = "Goto Page#" & vbCrLf & "(1 to " & CStr(PageNumber + 1) & ")"
    Picture1.SetFocus
End Sub

Private Sub Form_Click()
    picPrintOptions.Visible = False
    picGetFolder.Visible = False
    picGoto.Visible = False
End Sub


Private Sub Form_Initialize()
    '/* Used for Manifest files (Win XP)
    Call InitCommonControls
    'MakeXPButton cmd_quit
    'MakeXPButton cmd_print
    'MakeXPButton cmdFullPage
    'MakeXPButton cmdGoTo
    'MakeXPButton Command1(0)
    'MakeXPButton Command1(1)
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = 71 Or KeyAscii = 103 Then cmdGoTo_Click
End Sub