frmpz_print.frm

一个用VB写的财务软件源码

VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Object = "{7802D41A-28B0-43C4-95EA-17B7E32337D1}#1.0#0"; "CellCtrl5.ocx"
Begin VB.Form frmPz_Print 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "打印预览"
   ClientHeight    =   7440
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   11280
   Icon            =   "frmPz_Print.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   7440
   ScaleWidth      =   11280
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  '所有者中心
   Begin CELL50Lib.Cell cllr 
      Height          =   5535
      Left            =   120
      TabIndex        =   9
      Top             =   1800
      Width           =   10335
      _Version        =   65536
      _ExtentX        =   18230
      _ExtentY        =   9763
      _StockProps     =   0
   End
   Begin VB.CommandButton ReFormat 
      Cancel          =   -1  'True
      Caption         =   "调整(&A)"
      CausesValidation=   0   'False
      Height          =   345
      Left            =   2520
      TabIndex        =   8
      Top             =   1320
      Width           =   1050
   End
   Begin VB.CommandButton cmdCancel 
      Caption         =   "退出(&E)"
      CausesValidation=   0   'False
      Height          =   345
      Left            =   1320
      TabIndex        =   4
      Top             =   1320
      Width           =   1050
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "确定(&O)"
      Default         =   -1  'True
      Height          =   345
      Left            =   120
      TabIndex        =   3
      Top             =   1320
      Width           =   1050
   End
   Begin VB.Frame Frame1 
      Caption         =   "范围"
      Height          =   975
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   3450
      Begin VB.TextBox txtPageNumber 
         Alignment       =   1  'Right Justify
         Enabled         =   0   'False
         Height          =   270
         Left            =   1200
         TabIndex        =   7
         Text            =   "0"
         Top             =   240
         Width           =   735
      End
      Begin VB.TextBox txtPageFrom 
         Alignment       =   1  'Right Justify
         BackColor       =   &H80000009&
         Height          =   270
         Left            =   1200
         TabIndex        =   2
         Text            =   "1"
         Top             =   600
         Width           =   540
      End
      Begin MSComCtl2.UpDown updPageFrom 
         Height          =   270
         Left            =   1680
         TabIndex        =   1
         Top             =   600
         Width           =   240
         _ExtentX        =   423
         _ExtentY        =   476
         _Version        =   393216
         Value           =   1
         AutoBuddy       =   -1  'True
         BuddyControl    =   "txtPageFrom"
         BuddyDispid     =   196613
         OrigLeft        =   1680
         OrigTop         =   600
         OrigRight       =   1920
         OrigBottom      =   870
         Min             =   1
         SyncBuddy       =   -1  'True
         BuddyProperty   =   65547
         Enabled         =   -1  'True
      End
      Begin VB.Label Label2 
         AutoSize        =   -1  'True
         Caption         =   "总页数："
         Height          =   180
         Left            =   240
         TabIndex        =   6
         Top             =   240
         Width           =   720
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "指定页号："
         Height          =   180
         Left            =   240
         TabIndex        =   5
         Top             =   645
         Width           =   900
      End
   End
End
Attribute VB_Name = "frmPz_Print"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Public pz As New clsVoucher
Private fCount As Integer
Private sFileName As String

'目的:预览当前页
Public Sub uPreview()
   CllR.PrintPreview 1, CllR.GetCurSheet
End Sub

'目的:打印选中工作区
Public Sub uPrint()
    Dim frmPage As frmPageSet
    Dim lTotalPages As Long, i As Long
    
    lTotalPages = CllR.GetTotalSheets
    Set frmPage = New frmPageSet
    With frmPage
        CllR.PrintPageSetup
        .uiMaxPage = lTotalPages
        .uiPresentPage = CllR.GetCurSheet + 1
        .Show 1
        If .Ok Then
            For i = .uiFromPage To .uiToPage
                If Not .uiSzFsSet Then
                  MsgBox "请插入纸张...", vbInformation
                End If

                CllR.SetCurSheet i - 1
                CllR.PrintSheet 0, i - 1
            Next i
        End If
    End With
    Unload frmPage
    
End Sub

Public Function getFlMax() As Integer
getFlMax = pz.DataSet.getCount
End Function
Public Function getFlMin() As Integer
getFlMin = 0
End Function

Private Sub CllR_CalcFunc(ByVal Name As String, ByVal rettype As Long, ByVal paranum As Long)
Dim vArgum() As Variant
Dim i As Integer
ReDim vArgum(2)
vArgum(0) = CllR.GetFuncStringPara(0, paranum)
vArgum(1) = CllR.GetFuncDoublePara(1, paranum)
Select Case UCase(Name)
Case UCase("FristFl")
    fCount = getFlMin
    CllR.SetFuncResult fCount, "", 0
Case UCase("PreviousFl")
    If fCount > getFlMin Then
        fCount = fCount - 1
    Else
        fCount = getFlMin
    End If
    CllR.SetFuncResult fCount, "", 0
Case UCase("NextFl")
    If fCount < getFlMax Then
        fCount = fCount + 1
    Else
        fCount = getFlMax
    End If
    CllR.SetFuncResult fCount, "", 0
Case UCase("LastFl")
    fCount = getFlMax
    CllR.SetFuncResult fCount, "", 0
Case UCase("NextMode")
    
Case Else
    CllR.SetFuncResult 0, CalcFunction(Name, vArgum), 1
End Select
End Sub

Private Sub cllR_MouseRClick(ByVal Col As Long, ByVal Row As Long, ByVal updn As Long)
CllR.CellPropertyDlg
End Sub

Private Sub cmdCancel_Click()
Unload Me
End Sub

Private Sub cmdOk_Click()
Dim L As Long
If IsNumeric(txtPageFrom) = True Then
    L = CLng(txtPageFrom.text)
    If L >= 1 And L <= CLng(txtPageNumber) Then
        CllR.SetCurSheet L - 1
        CllR.PrintPreview 1, L - 1
    End If
End If
End Sub

Private Sub Form_Initialize()
sFileName = App.Path + "\CellFiles\凭证.cll"
End Sub

Private Sub reformat_Click()
    Me.Width = 11370
    Me.Height = 7815
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyF9 And Shift = vbAltMask + vbCtrlMask Then
    Me.Width = 11370
    Me.Height = 7815
End If
End Sub

Private Sub form_load()
CllR.Login "南京伊康计算机工程公司", "11010504", "0060-1733-7722-3004"
Me.Width = 3745
Me.Height = 2190

End Sub

Public Sub Fill()
Dim s As String
Dim pageNumber As Integer
Dim rowNumber As Integer
Dim lRow As Integer
Dim i As Integer
Dim lTotal As Long
s = CllR.GetCellNote(1, 1, 0)
If IsNumeric(s) Then
    lRow = CInt(s)
Else
    lRow = 6
End If
lTotal = pz.DataSet.getCount + lRow - 1
pageNumber = lTotal \ lRow
i = 1
While i < pageNumber
    CllR.InsertSheet 0, 1
    CllR.CopySheet 0, 1
'    CllR.CalculateSheet i
    i = i + 1
Wend
End Sub

Public Sub DefineFunction(ByRef cll As Cell)
Dim str As String

str = """凭证套打"" String jbxx( String str )"
str = str & vbCrLf & "BEGIN_HELP"
str = str & vbCrLf & "凭证基本函数 String jbxx( String str )"
str = str & vbCrLf & "END_HELP"
cll.DefineFunctions str

str = """凭证套打"" String fl(String str,Double index )"
str = str & vbCrLf & "BEGIN_HELP"
str = str & vbCrLf & "凭证分录函数 String fl( String str,Double index )"
str = str & vbCrLf & "END_HELP"
cll.DefineFunctions str

str = """凭证套打"" Double FristFl()"
str = str & vbCrLf & "BEGIN_HELP"
str = str & vbCrLf & "第一条分录号 Double FristFl()"
str = str & vbCrLf & "END_HELP"
cll.DefineFunctions str

str = """凭证套打"" Double PreviousFl()"
str = str & vbCrLf & "BEGIN_HELP"
str = str & vbCrLf & "上一条分录号 Double PreviousFl()"
str = str & vbCrLf & "END_HELP"
cll.DefineFunctions str

str = """凭证套打"" Double NextFl()"
str = str & vbCrLf & "BEGIN_HELP"
str = str & vbCrLf & "下一条分录号 Double NextFl()"
str = str & vbCrLf & "END_HELP"
cll.DefineFunctions str

str = """凭证套打"" Double LastFl()"
str = str & vbCrLf & "BEGIN_HELP"
str = str & vbCrLf & "末一条分录号 Double LastFl()"
str = str & vbCrLf & "END_HELP"
cll.DefineFunctions str

str = """凭证套打"" Double ModeNext(Double Max)"
str = str & vbCrLf & "BEGIN_HELP"
str = str & vbCrLf & "下一号Double ModeNext(Double Max)"
str = str & vbCrLf & "END_HELP"
cll.DefineFunctions str
End Sub


Public Function CalcFunction(ByVal FuncName As String, ByRef vArgum() As Variant) As Variant
    Dim a() As String
    Dim i As Integer
    Select Case UCase(FuncName)
    Case UCase("jbxx")
        pz.InfToArray a
        If Not IsEmpty(a) Then
            For i = LBound(a) To UBound(a)
                If UCase(a(i, 0)) = UCase(vArgum(0)) Then
                    CalcFunction = a(i, 1)
                    Exit For
                End If
            Next i
        End If
    Case UCase("fl")
        Dim Index As Integer
        If IsNumeric(vArgum(1)) = True Then
            Index = CInt(vArgum(1))
        Else
            Index = 0
        End If
        pz.DataSet.Item(Index).toArray a
        If Not IsEmpty(a) Then
            For i = LBound(a) To UBound(a)
                If UCase(a(i, 0)) = UCase(vArgum(0)) Then
                    CalcFunction = a(i, 1)
                    Exit For
                End If
            Next i
        End If
    End Select
End Function

Private Sub Form_Resize()
'CllR.Left = Me.ScaleLeft
'CllR.Top = Me.ScaleTop
'CllR.Width = Me.ScaleWidth
'CllR.Height = Me.ScaleHeight
End Sub

Private Sub Form_Unload(Cancel As Integer)
If CllR.GetTotalSheets > 1 Then
    CllR.DeleteSheet 1, CllR.GetTotalSheets - 1
End If
CllR.SaveFile sFileName, 1
End Sub

Public Property Get CellFile() As String
CellFile = sFileName
End Property

Public Property Let CellFile(ByVal vNewValue As String)
If Trim(vNewValue) = "" Then
    sFileName = App.Path + "\CellFiles\凭证.cll"
Else
    sFileName = Trim(vNewValue)
End If
End Property

Public Sub CellShow()
CllR.OpenFile sFileName, ""
DefineFunction CllR
'CllR.CalcManaually = True
Fill
'CllR.CalcManaually = False
CllR.CalculateAll
CllR.Redraw
txtPageNumber = CllR.GetTotalSheets
updPageFrom.Max = CLng(txtPageNumber)
End Sub