frmvoucher.frm

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

         EndProperty
      End
      Begin MSComctlLib.Toolbar tbrSplit 
         Height          =   330
         Left            =   7455
         TabIndex        =   15
         Top             =   120
         Width           =   405
         _ExtentX        =   714
         _ExtentY        =   582
         ButtonWidth     =   609
         ButtonHeight    =   582
         Wrappable       =   0   'False
         Style           =   1
         ImageList       =   "ImageList1"
         _Version        =   393216
      End
   End
   Begin VB.Menu mnuFile 
      Caption         =   "文件(&F)"
      Begin VB.Menu mnuVoucherSwitch 
         Caption         =   "科目代码/名称切换"
         Shortcut        =   {F8}
      End
      Begin VB.Menu mnuEntrySwitch 
         Caption         =   "凭证/辅助分录切换"
         Shortcut        =   %{BKSP}
      End
      Begin VB.Menu mnuVoucherBar5 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFilePreview 
         Caption         =   "打印预览"
         Shortcut        =   ^R
      End
      Begin VB.Menu mnuFilePrint 
         Caption         =   "打印"
         Shortcut        =   ^P
      End
      Begin VB.Menu mnuFileBar 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit 
         Caption         =   "退出"
         Shortcut        =   ^T
      End
   End
   Begin VB.Menu mnuVoucher 
      Caption         =   "凭证(&V)"
      Begin VB.Menu mnuVoucherNew 
         Caption         =   "新增"
         Shortcut        =   ^N
      End
      Begin VB.Menu mnuVoucherEdit 
         Caption         =   "修改"
         Shortcut        =   ^E
      End
      Begin VB.Menu mnuVoucherDelete 
         Caption         =   "删除"
         Enabled         =   0   'False
         Visible         =   0   'False
      End
      Begin VB.Menu mnuVoucherSave 
         Caption         =   "保存"
         Shortcut        =   ^S
      End
      Begin VB.Menu mnuVoucherCancel 
         Caption         =   "取消"
      End
      Begin VB.Menu mnuVoucherBar 
         Caption         =   "-"
      End
      Begin VB.Menu mnuVoucherTempSave 
         Caption         =   "暂存"
         Shortcut        =   ^{F11}
         Visible         =   0   'False
      End
      Begin VB.Menu mnuVoucherLoadTemp 
         Caption         =   "暂取"
         Shortcut        =   ^{F12}
         Visible         =   0   'False
      End
      Begin VB.Menu mnuVoucherBar1 
         Caption         =   "-"
         Visible         =   0   'False
      End
      Begin VB.Menu mnuVoucherClone 
         Caption         =   "复制凭证..."
      End
      Begin VB.Menu mnuVoucherNewclone 
         Caption         =   "新增复制凭证"
      End
      Begin VB.Menu mnuVoucherBounceback 
         Caption         =   "凭证反冲"
      End
      Begin VB.Menu mnuVoucherBar2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuVoucherInsertRow 
         Caption         =   "插行"
      End
      Begin VB.Menu mnuVoucherDeleteRow 
         Caption         =   "删行"
      End
      Begin VB.Menu mnuVoucherRefresh 
         Caption         =   "刷新"
         Shortcut        =   {F5}
      End
      Begin VB.Menu mnuVoucherClonesummary 
         Caption         =   "复制上行摘要"
         Shortcut        =   ^A
      End
      Begin VB.Menu mnuVoucherDirect 
         Caption         =   "切换金额方向"
         Shortcut        =   ^{F6}
      End
      Begin VB.Menu mnuVoucherHelp 
         Caption         =   "获取帮助"
      End
      Begin VB.Menu mnuVoucherBar3 
         Caption         =   "-"
      End
      Begin VB.Menu mnuVoucherInsertFzRow 
         Caption         =   "插行(辅助信息)"
         Shortcut        =   ^{F2}
      End
      Begin VB.Menu mnuVoucherDeleteFzRow 
         Caption         =   "删行(辅助信息)"
         Shortcut        =   ^{F3}
      End
      Begin VB.Menu mnuVoucherBar4 
         Caption         =   "-"
      End
      Begin VB.Menu mnuVoucherLoadModel 
         Caption         =   "导入凭证模版"
         Shortcut        =   ^M
      End
   End
   Begin VB.Menu mnuBrowse 
      Caption         =   "浏览(&B)"
      Begin VB.Menu mnuBrowseSearch 
         Caption         =   "查询"
         Shortcut        =   ^Q
      End
      Begin VB.Menu mnuBrowseLocate 
         Caption         =   "定位"
         Shortcut        =   ^L
      End
      Begin VB.Menu mnuBrowseBar 
         Caption         =   "-"
      End
      Begin VB.Menu mnuBrowseForword 
         Caption         =   "前一张"
         Shortcut        =   ^F
      End
      Begin VB.Menu mnuBrowseBackword 
         Caption         =   "后一张"
         Shortcut        =   ^B
      End
   End
   Begin VB.Menu mnuAddin 
      Caption         =   "外接(&A)"
      Enabled         =   0   'False
      Visible         =   0   'False
      Begin VB.Menu mnuAddinCalc 
         Caption         =   "计算器"
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助(&H)"
      Begin VB.Menu mnuHelpFile 
         Caption         =   "联机帮助"
         Shortcut        =   {F1}
      End
   End
End
Attribute VB_Name = "frmVoucher"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Const COL_DEBIT = 3
Const COL_CREDIT = 4
Const Cols = 4

Const COL_WIDTH = "0.3,0.3,0.2,0.2"

Public Event Unload()
Public Event SaveFinish(ByRef oVoucher As clsVoucher)

Private COL_SUBJECT As Integer
Private COL_SUMMARY As Integer

'是否自动编号
Private m_bAutomaticNumber As Boolean
'是否使用全路径
Private m_bFullPath As Boolean

'原始凭证
Private m_oVoucher As New clsVoucher
'操作时凭证
Private m_oTempVoucher As New clsVoucher
'基本的全局变量
Private m_oGlo As New clsGlobal
'系统的全局变量
Private m_oGloSys As New clsGlobalSys
'辅助头
Private m_FzHeadCollection As New VBA.Collection
'特定的外接模块
Private LoadingObject As Object
'特定的外接模块名称
Private LoadingObjectName As String
'外接对象
Private Obj() As Object
'外接对象数量
Private iObjCount As Integer
'是否允许添加外接对象
Private bAllowAddinObj As Boolean
'暂存、暂取对象
Private oTempSave As New VoucherDataExtend.VoucherToTxt
'是否显示科目名称
Private IsDisplaySubjectName As Boolean
'操作行（凭证）
Dim OldRow As Integer
'是否允许不检查执行SaveEdit(凭证、辅助获取功能)
Dim bAllowNoCheckSaveEdit As Boolean
Dim bFzGetFocus As Boolean
Dim bVoucherGetFocus As Boolean
Dim bLoad As Boolean
Dim iChangeColWidth As Integer
Dim rstFZColWidth As New Recordset  '辅助列宽数据集
Dim lID As Integer '互斥代码
Dim iID As Integer '互斥代码
Dim sFunctionName As String '互斥功能名称
Private oItemHelp As New HelpItem.clsHelpItem

Const DisenabledColor = &HFFFF00 '不能使用到期日颜色

Private m_IsModePrint As Boolean '是否套打凭证

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub cboPZZL_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then SendKeys "{TAB}"
End Sub

Private Sub cllFz_AllowDelCell(ByVal col As Long, ByVal row As Long, approve As Long)
Dim iTm As clsFzHead
Dim lcol As Long
    lcol = cllFz.GetCurrentCol
    If m_FzHeadCollection.Count > 0 Then
        Set iTm = m_FzHeadCollection.Item(lcol)
        Select Case iTm.uType
        Case "xm", "bm", "yw", "kh", "gys", "gr", "jsfs", "pjlx"
            Call cllFz.SetCellNote(lcol, cllFz.GetCurrentRow, 0, "")
            If iTm.uType = "pjlx" Then
                cllFz.SetCellNote cllFz.GetCols(0) - 1, cllFz.GetCurrentRow, 0, ""
                cllFz.SetCellNote lcol + 1, cllFz.GetCurrentRow, 0, ""
                cllFz.SetCellInput cllFz.GetCols(0) - 1, cllFz.GetCurrentRow, 0, 5
            End If
        Case Else
            OnFzJeChange cllVoucher.GetCurrentRow
        End Select
    End If
End Sub

Private Sub cllFz_AllowEditCell(ByVal col As Long, ByVal row As Long, approve As Long)
Dim iTm As New clsFzHead
Dim s As String
Dim Je As Double
If row > 1 And m_FzHeadCollection.Count > 0 Then
    Set iTm = m_FzHeadCollection.Item(col)
    Select Case iTm.uType
    Case "xm", "bm", "yw", "kh", "gys", "gr", "jsfs", "pjlx"
        s = cllFz.GetCellNote(col, row, 0)
        If s <> "" Then
            cllFz.s col, row, cllFz.GetCurSheet, s
        End If
    Case "dqr", "pjrq"
        cllFz.s col, row, cllFz.GetCurSheet, Replace(Format(CDate(cllFz.GetCellDouble(col, row, 0)), "yyyy-MM-dd"), "'", "")
    Case "je"
      s = cllFz.GetCellNote(col, row, 0)
        If s <> "" Then
            cllFz.d col, row, cllFz.GetCurSheet, Format(IIf(s = "", 0, Val(s)), "#,###,###.00")
        End If
    End Select
End If
End Sub

Private Sub cllFz_AllowInputFormula(ByVal row As Long, ByVal col As Long, approve As Long)
    approve = 0
End Sub

Private Sub cllFz_AllowSizeCol(ByVal col As Long, ByVal row As Long, approve As Long)
    approve = 1
    iChangeColWidth = col
End Sub

Private Sub cllFz_EditFinish(text As String, approve As Long)
Dim iCol As Integer
Dim iRow As Integer
Dim iTm As New clsFzHead
Dim s As String
Dim sCode As String
Dim sName As String
Dim sText As String
Dim pos As String
Dim d As Double
Dim tmpItem As clsFzHead
    iCol = cllFz.GetCurrentCol
    iRow = cllFz.GetCurrentRow
    If bAllowNoCheckSaveEdit Then Exit Sub
    If iCol < 1 Then text = "": Exit Sub
    text = Replace(text, "'", "")
    Set iTm = m_FzHeadCollection.Item(iCol)
    Select Case iTm.uType
    Case "yhph"
        If LenB(StrConv(text, vbFromUnicode)) > 12 Then
            MsgBox "不能超过12英文字符的长度！", , ""
            approve = 0
        Else
            If IsDate(text) Then
                approve = 0
            End If
        End If
    Case "pjrq"
      On Error GoTo error
        If IsDate(CDate(text)) Then
            If IsVialdDate = True Then
                If CDate(text) > CDate(dtpPzDate.value) Then
                    MsgBox "票据日期大于凭证日期", vbInformation, "提示"
                    approve = 0
                
                End If
                   
            Else
                approve = 0