voucher.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 = "CVoucher"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit 
Private mCn As adodb.Connection

Private mVchID As eumVchType
Private msVchID As String * 2
Private mTblName As String
Private mIDFldName As String

Private mRowData As Dictionary
'''private mUniqueFilter As Dictionary
Private mIDValue As String

Private Enum eumTblAct
      AddRow
      EditRow
      DeleteRow
End Enum
Public Enum eumVchType
      银行存款单 = "01"
      银行取款单 = "02"
      内部存款单 = "03"
      内部取款单 = "04"
      银行贷款单 = "05"
      内部贷款单 = "06"
      内部拆借单 = "07"
      本金还款单_银行贷款 = "08"
      本金还款单_内部贷款 = "09"
      本金还款单_内部拆借 = "12"
      利息还款单_银行贷款 = "10"
      利息还款单_内部贷款 = "11"
      利息还款单_内部拆借 = "13"
      对外结算单 = "14"
      内部结算单 = "15"
      利息单 = "16"
''      催款通知单
End Enum


Public Function editChecker(newChecker As Variant, IDValue As String)
      Dim rsTm As New adodb.Recordset
      With rsTm
'''            .CursorType = adOpenKeyset
'''            .LockType = adLockOptimistic
'''            .Open "Select * from " + mTblName + " where " + mIDFldName + "  = '" + IDvalue + "'", mCn, , , adCmdText
'''            .Fields!cCheckCode = newChecker
'''            .Update
      End With
      Set mRowData = New Dictionary
      mRowData.Add "cCheckCode", newChecker
      mIDValue = IDValue
      tblAction mTblName, EditRow
      mRowData.RemoveAll
End Function

Public Function isChecked(sIDCode As String) As Boolean
      Dim Rs As New adodb.Recordset
      Dim sQ As String
      sQ = "Select * from " + mTblName _
      + " where " + mIDFldName + " = '" + sIDCode + "'"
      With Rs
            .Open sQ, mCn, adOpenForwardOnly, adLockReadOnly, adCmdText
            If .EOF Then
                  MsgBox "BAD"
            Else
                  If IsNull(.Fields!cCheckCode) Then
                        isChecked = False
                  Else
                         isChecked = True
                  End If
            End If
      End With

End Function
Public Function isBooked(sIDCode As String) As Boolean
      Dim Rs As New adodb.Recordset
      Dim sQ As String
      sQ = "Select * from " + mTblName _
      + " where " + mIDFldName + " = '" + sIDCode + "'"
      With Rs
            .Open sQ, mCn, adOpenForwardOnly, adLockReadOnly, adCmdText
            If .EOF Then
                  MsgBox "BAD"
            Else
                  If IsNull(.Fields!cBookCode) Then
                        isBooked = False
                  Else
                         isBooked = True
                  End If
            End If
      End With

End Function

'' 新增单据时，获取最大业务号
'''''Public Function getMaxID() As String
'''''      Dim sID As String
'''''      Dim sVchID As String
'''''      Select Case mVchID
'''''            Case 银行存款单
'''''                  sID = Getmaxbh(msVchID, "cSavID")
'''''            Case 银行取款单
'''''            Case 内部存款单
'''''            Case 内部取款单
'''''      End Select
'''''      getMaxID = sID
'''''End Function

'Private Sub tblAction(tblName As String, Action As eumTblAct)                'cuidong 2001.08.24
Private Function tblAction(tblName As String, Action As eumTblAct) As Boolean 'cuidong 2001.08.24
''      tblAction = 1
      On Error GoTo doErr
      tblAction = False 'cuidong 2001.08.24
      
      Dim sQ As String
'''      Dim rstTem As New adodb.Recordset
'''      With rstTem
            Select Case Action
                  Case AddRow
''''                        .CursorType = adOpenKeyset
''''                        .LockType = adLockOptimistic
''''                        .Open "select * from " + tblName, mCn, , , adCmdText
''''                        .AddNew
''''                        fillCurRow rstTem
''''                        .Update
''''                        .Close
                         sQ = getAddSQL
                  Case DeleteRow
''''                        mCn.Execute "Delete from " + tblName + " where " + mIDFldName + "  = '" + mIDValue + "'" 'getFilter
                        sQ = "Delete from " + tblName + " where " + mIDFldName + "  = '" + mIDValue + "'"
                  Case EditRow
''''                        .CursorType = adOpenKeyset
''''                        .LockType = adLockOptimistic
''''                        .Open "Select * from " + tblName + " where " + mIDFldName + "  = '" + mIDValue + "'", mCn, , , adCmdText
''''                        fillCurRow rstTem
''''                        .Update
''''                        .Close
                        sQ = getUpdateSQL(mIDValue)
            End Select
'''      End With
      
     mCn.Execute sQ
     tblAction = True 'cuidong 2001.08.24
      Exit Function
doErr:
'''''''''      MsgBox Err.Description
      'cuidong 2001.08.24
      '-----------------------
'      MsgBox "其他工作站正在保存，请过一会儿再试！", vbCritical, zjGl_Name
      MsgBox "由于网络原因，暂时不能保存。" & vbCrLf & vbCrLf & "请稍后再试。", vbOKOnly + vbInformation, zjGl_Name  'cuidong 2001.08.23
      '-----------------------
End Function
'public function

Public Property Get connDB() As adodb.Connection
      connDB = mCn
End Property

Public Property Set connDB(ByVal vNewValue As adodb.Connection)
      Set mCn = vNewValue
End Property

''''''Private Sub fillCurRow(rst As adodb.Recordset)
''''''      Dim Flds
''''''      Dim i As Long
''''''      Dim sFldName As String
''''''      Dim Last As Long
''''''      With rst
''''''      Flds = mRowData.Keys
''''''      Last = mRowData.Count - 1
''''''      For i = 0 To Last
''''''            sFldName = CStr(Flds(i))
'''''''                  .Fields(sFldName) = mRowData.Item(sFldName)
''''''                  Debug.Print sFldName + "----" + CStr(mRowData.Item(sFldName))
''''''      Next
''''''      End With
''''''End Sub


''''Public Property Get Fld_Value() As Dictionary
''''      Set Fld_Value = mUniqueFilter
''''End Property
''''
''''Public Property Set Fld_Value(ByVal vNewValue As Dictionary)
''''      Set mUniqueFilter = vNewValue
''''End Property
'''''Private Function getFilter() As String
'''''      Dim Flds
'''''      Dim i As Long
'''''      Dim sFldName As String, sValue As String
'''''      Dim sWhere As String
'''''      sWhere = ""
'''''      With mUniqueFilter
'''''      Flds = .Keys
'''''            For i = 0 To .Count - 1
'''''                  sFldName = CStr(Flds(i))
'''''                  Select Case Left(sFldName, 1)
'''''                        Case "d"
'''''                              sValue = "'" + Format(.Item(sFldName), "yyyy-mm-dd") + "'"
'''''                        Case "m", "n", "i"
'''''                              sValue = CStr(.Item(sFldName))
'''''                        Case Else 'text
'''''                              sValue = "'" + CStr(.Item(sFldName)) + "'"
'''''                  End Select
'''''                  sWhere = sWhere + sFldName + " = " + sValue + " And "
'''''            Next
'''''      End With
'''''      sWhere = " Where " + sWhere
'''''      sWhere = Left(sWhere, Len(sWhere) - 4)
'''''      getFilter = sWhere
'''''
'''''End Function
Private Function getSQLValue(FldName As String, vValue As Variant) As String
      Dim sValue As String
      If IsNull(vValue) Then
            getSQLValue = "NULL"
            Exit Function
      End If
      If mTblName = "FD_Cred" And LCase(FldName) = "mmoneying" Then
           sValue = "'" + CStr(vValue) + "'"
           getSQLValue = sValue
           Exit Function
      End If
      
      If FldName = "icen_id" Then             'ZhaoChunLi 2001.01.06
           sValue = "'" + CStr(vValue) + "'"  'ZhaoChunLi 2001.01.06
           getSQLValue = sValue               'ZhaoChunLi 2001.01.06
           Exit Function                      'ZhaoChunLi 2001.01.06
      End If                                  'ZhaoChunLi 2001.01.06
      
      Select Case Left(FldName, 1)
            Case "d"
                  sValue = "'" + Format(vValue, "yyyy-mm-dd") + "'"
            Case "m", "n", "i"
                  sValue = CStr(vValue)
            Case Else 'text
                  sValue = "'" + CStr(vValue) + "'"
      End Select
     getSQLValue = sValue
End Function
Private Function getAddSQL() As String
  Dim Flds
      Dim i As Long
      Dim sFldName As String
      Dim Last As Long
      Dim sFlds As String, sVals As String
      Flds = mRowData.Keys
      Last = mRowData.Count - 1
      sFlds = ""
      sVals = ""
      For i = 0 To Last
            sFldName = Flds(i)
            sFlds = sFlds + sFldName + ","
            sVals = sVals + getSQLValue(sFldName, mRowData.Item(sFldName)) + ","
      Next
      sFlds = Left(sFlds, Len(sFlds) - 1)
      sVals = Left(sVals, Len(sVals) - 1)
      getAddSQL = "INSERT INTO " + mTblName + "(" + sFlds + ")" _
            + " VALUES (" + sVals + ")"
End Function
Private Function getUpdateSQL(IDValue As String) As String
  Dim Flds
      Dim i As Long
      Dim sFldName As String, sValue As String, sT As String
      Dim Last As Long
'''      Dim sFlds As String, sVals As String
      Flds = mRowData.Keys
      Last = mRowData.Count - 1
      For i = 0 To Last
            sFldName = Flds(i)
            sValue = getSQLValue(sFldName, mRowData.Item(sFldName))
            sT = sT + sFldName + " = " + sValue + ","
      Next
      sT = Left(sT, Len(sT) - 1)
      getUpdateSQL = "update " + mTblName + " Set " + sT _
            + " where " + mIDFldName + " = '" + IDValue + "'"
End Function

Public Property Get voucherType() As eumVchType
      voucherType = mVchID
End Property

Public Property Let voucherType(ByVal vNewValue As eumVchType)
      mVchID = vNewValue
      If mVchID > 9 Then
            msVchID = CStr(mVchID)
      Else
            msVchID = "0" + CStr(mVchID)
      End If

      Select Case mVchID
            Case 银行存款单, 内部存款单
                  mTblName = "FD_sav"
                  mIDFldName = "cSavID"
            Case 银行取款单, 内部取款单
                  mTblName = "FD_Fetch"
                  mIDFldName = "cFetID"
            Case 银行贷款单, 内部贷款单
                  mTblName = "FD_Cred"
                  mIDFldName = "cCreID"
            Case 内部拆借单
                  mTblName = "FD_UnwDeb"
                  mIDFldName = "cUnwID"
            Case 本金还款单_银行贷款, 本金还款单_内部贷款
                  mTblName = "FD_Return"
                  mIDFldName = "cRetID"
            Case 本金还款单_内部拆借
                  mTblName = "FD_UnwRet"
                  mIDFldName = "cRetID"
            Case 利息还款单_银行贷款, 利息还款单_内部贷款
                  mTblName = "FD_CreAcrRcp"
                  mIDFldName = "cCraID"
            Case 利息还款单_内部拆借
                  mTblName = "FD_UnwAcrRcp"
                  mIDFldName = "cUnaID"
            Case 对外结算单, 内部结算单
                  mTblName = "FD_SettAcc"
                  mIDFldName = "cSetID"
            Case 利息单
                  mTblName = "FD_CadAcr"
                  mIDFldName = "cCarID"
''            Case 催款通知单
            Case Else
      End Select
End Property
'Public Function Add(RowData As Dictionary)           'cuidong 2001.08.24
Public Function Add(RowData As Dictionary) As Boolean 'cuidong 2001.08.24
      Set mRowData = RowData
      'tblAction mTblName, AddRow       'cuidong 2001.08.24
      Add = tblAction(mTblName, AddRow) 'cuidong 2001.08.24
      mRowData.RemoveAll
End Function
Public Function Delete(IDValue As String)
       mIDValue = IDValue
      tblAction mTblName, DeleteRow
      
End Function
'Public Function edit(RowData As Dictionary, IDValue As String)           'cuidong 2001.08.24
Public Function edit(RowData As Dictionary, IDValue As String) As Boolean 'cuidong 2001.08.24
            Set mRowData = RowData
            mIDValue = IDValue
            'tblAction mTblName, EditRow        'cuidong 2001.08.24
            edit = tblAction(mTblName, EditRow) 'cuidong 2001.08.24
            mRowData.RemoveAll
End Function
'首页、上页、下页、末页设置
Public Sub setPageState(tlb As Object, cboID As Object, Optional isnw As Boolean)
    Dim i As Integer, mRecords As Integer, CurRecord As Integer
    If IsMissing(isnw) Then
        isnw = False
    End If
    If isnw Then
        mRecords = 0
    Else
        mRecords = cboID.ListCount
    End If
    If mRecords = 0 Then
        tlb.Buttons("FirstPage").Enabled = False
        tlb.Buttons("PriorPage").Enabled = False
        tlb.Buttons("NextPage").Enabled = False
        tlb.Buttons("LastPage").Enabled = False
    Else
        CurRecord = cboID.ListIndex