frmaccountcard.frm

金算盘软件代码

   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "辅助核算(&E)"
      Height          =   180
      Index           =   2
      Left            =   3000
      TabIndex        =   22
      Top             =   2610
      Width           =   990
   End
   Begin VB.Label Label4 
      Caption         =   "科目性质(&P)"
      Height          =   255
      Left            =   120
      TabIndex        =   6
      Top             =   1230
      Width           =   1035
   End
   Begin VB.Label Label2 
      Caption         =   "科目类别(&T)"
      Height          =   225
      Left            =   120
      TabIndex        =   4
      Top             =   870
      Width           =   1005
   End
   Begin VB.Label Label1 
      Caption         =   "科目名称(&N)"
      Height          =   225
      Index           =   1
      Left            =   120
      TabIndex        =   2
      Top             =   510
      Width           =   1095
   End
   Begin VB.Label Label1 
      Caption         =   "科目编号(&C)"
      Height          =   195
      Index           =   0
      Left            =   120
      TabIndex        =   0
      Top             =   150
      Width           =   1095
   End
End
Attribute VB_Name = "frmAccountCard"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'''''''''''''''''''''''''''''''''''''''''''''''
'科目卡片窗体
'
'作者:苏涛,郑权
'
'日期:1998.6.23
'接口：   AddCard   增加科目记录。
'                   参数：intModal 显示模式，strName 用户输入值
'         EditCard  修改科目记录。
'                   参数： lngID 被修改的记录的ID，intModal 显示模式
'         DelCard   删除科目记录。
'                   参数： lngID 被删除的记录的ID
''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Option Explicit
Option Compare Text

Public mblnSelCur As Boolean    'TRUE-选择了核算币种
Private mblnIsInit As Boolean
Private mblnIsList As Boolean
Private mblnAllCur As Boolean
Private mblnPartCur As Boolean
Private mblnIsInActive As Boolean
Private mblnAcntNEdit As Boolean
Private mblnSuit As Boolean
Private mblnChkQuantity As Boolean
Private mblnOAllCur As Boolean
Private mblnOPartCur As Boolean
Private mblnAid(6) As Boolean
Private mblnCurAllowEdit As Boolean
Private mstrCode As String
Private mstrOldCode As String
Private mstrName As String
Private mstrOldName As String
Private mstrUnit As String
Private mintDirection As Integer
Private mintDirectionOld As Integer
Private mintOldLevel As Integer
Private mintLevel As Integer
Private mblnIsDetail As Boolean   '是否是末级
Private mblnPIsDetail As Boolean  '上级是否是末级
Private mblnPIsInActive As Boolean
Private mblnIsNew As Boolean      '是否新增
Private mlngAccountID As Long     'ID
Private mlngPCodeID As Long       '上级ID
Private mlngNatureID As Long
Private mlngTypeID As Long
Private mlngOldTypeID As Long
Private mstrFullName As String
Private mstrCurID() As String
Private mstrOldFullName As String
Private mstrPre As String         '当前编码的前缀
Private mblnIsChanged As Boolean      '是否改变
Private mtxtAccountNature As String
Private mstrLastCode As String
Private mstrStartDate As String
Private mblnPisActive As Boolean     '上级科目的停用

'直接增加会计科目
Public Function AddAccount(ByVal strAccount As String, Optional ByVal strPath As String, Optional ByVal blnIsCopy As Boolean = False) As Integer
    Dim blnIsCustomer As Boolean, blnIsDepartment As Boolean
    Dim blnIsSuit As Boolean, blnIsEmployee As Boolean
    Dim blnIsClass1 As Boolean, blnIsClass2 As Boolean
    Dim blnIsCash As Boolean, blnIsStop As Boolean
    Dim blnIsQuantity As Boolean, blnIsCalcInterest As Boolean
    Dim intDirection As Integer
    Dim lngNatureID As Long, lngTypeID As Long
    Dim strUnit As String
    Dim strCode As String, strName As String, strTemp As String
    
    On Error GoTo ErrHandle
    AddAccount = 0
'    If Not GetString(strAccount, strCode, 1) Then Exit Function
    strCode = StringOut(strAccount, Chr(9))
'    If Not GetString(strAccount, strName, 2) Then Exit Function
    strName = StringOut(strAccount, Chr(9))
'    If Not GetString(strAccount, strTemp, 3) Then Exit Function
    strTemp = StringOut(strAccount, Chr(9))
    lngTypeID = CLng(strTemp)
    strTemp = StringOut(strAccount, Chr(9))
'    If Not GetString(strAccount, strTemp, 5) Then Exit Function
    strTemp = StringOut(strAccount, Chr(9))
    intDirection = CInt(strTemp)
'    If Not GetString(strAccount, strunit, 6) Then Exit Function
    strUnit = StringOut(strAccount, Chr(9))
'    If Not GetString(strAccount, strTemp, 7) Then Exit Function
    strTemp = StringOut(strAccount, Chr(9))
    mblnAllCur = (strTemp = "1")
    strTemp = StringOut(strAccount, Chr(9))
    strTemp = StringOut(strAccount, Chr(9))
'    If Not GetString(strAccount, strTemp, 10) Then Exit Function
    strTemp = StringOut(strAccount, Chr(9))
    lngNatureID = CLng(strTemp)
'    If Not GetString(strAccount, strTemp, 11) Then Exit Function
    strTemp = StringOut(strAccount, Chr(9))
    mblnSelCur = (strTemp = "1")
'    If Not GetString(strAccount, strTemp, 12) Then Exit Function
    strTemp = StringOut(strAccount, Chr(9))
    blnIsQuantity = (strTemp = "1")
'    If Not GetString(strAccount, strTemp, 13) Then Exit Function
    strTemp = StringOut(strAccount, Chr(9))
    blnIsCustomer = (strTemp = "1")
'    If Not GetString(strAccount, strTemp, 14) Then Exit Function
    strTemp = StringOut(strAccount, Chr(9))
    blnIsDepartment = (strTemp = "1")
'    If Not GetString(strAccount, strTemp, 15) Then Exit Function
    strTemp = StringOut(strAccount, Chr(9))
    blnIsEmployee = (strTemp = "1")
'    If Not GetString(strAccount, strTemp, 16) Then Exit Function
    strTemp = StringOut(strAccount, Chr(9))
    blnIsClass1 = (strTemp = "1")
'    If Not GetString(strAccount, strTemp, 17) Then Exit Function
    strTemp = StringOut(strAccount, Chr(9))
    blnIsClass2 = (strTemp = "1")
'    If Not GetString(strAccount, strTemp, 18) Then Exit Function
    strTemp = StringOut(strAccount, Chr(9))
    blnIsStop = (strTemp = "1")
'    If Not GetString(strAccount, strTemp, 19) Then Exit Function
    strTemp = StringOut(strAccount, Chr(9))
    blnIsCash = (strTemp = "1")
'    If Not GetString(strAccount, strTemp, 20) Then Exit Function
    strTemp = StringOut(strAccount, Chr(9))
    blnIsSuit = (strTemp = "1")
    strTemp = StringOut(strAccount, Chr(9))
    blnIsCalcInterest = (strTemp = "1")
    
    If strCode = "" Or strName = "" Then Exit Function
    If Not ItemIsExist("AccountType", "lngAccountTypeID", lngTypeID) Then Exit Function
    If lngNatureID < 0 Or lngNatureID > 5 Then Exit Function
    If mblnSelCur And Not blnIsCopy Then
        If Dir(strPath & "\AcntCur.Dat") <> "" Then
            If Not InitAccountCurrency(strCode, strPath & "\AcntCur.Dat") Then Exit Function
        Else
            If Not InitAccountCurrency(strCode, strPath & "\AccountCurrency.Dat") Then Exit Function
        End If
    End If
    InitNatureType
    mblnIsNew = True
    txtAccount(0).Text = strCode
    txtAccount(1).Text = strName
    cboAccount(0).Text = AccountX(lngTypeID, 0)
    cboAccount(1).Text = AccountX(lngNatureID, 1)
    optCheck(1).Value = mblnAllCur
    optCheck(2).Value = mblnSelCur
    optDirection(0).Value = (intDirection = 1)
    'chkSuit.Value=iif(.blnIsCalcExchange,1,0)
    chkQuantity.Value = IIf(blnIsQuantity, 1, 0)
    chkAid(0).Value = IIf(blnIsCustomer, 1, 0)
    chkAid(1).Value = IIf(blnIsDepartment, 1, 0)
    chkAid(2).Value = IIf(blnIsEmployee, 1, 0)
    chkAid(3).Value = IIf(blnIsCash, 1, 0)
    chkAid(4).Value = IIf(blnIsClass1, 1, 0)
    chkAid(5).Value = IIf(blnIsClass2, 1, 0)
    chkAid(6).Value = IIf(blnIsCalcInterest, 1, 0)
    chkStop.Value = IIf(blnIsStop, 1, 0)
    chkSuit.Value = IIf(blnIsSuit, 1, 0)
    txtAccount(2).Text = strUnit
    If SaveCard(True, blnIsCopy) Then
        AddAccount = 1
    Else
        Debug.Assert "jj"
    End If
ErrHandle:
End Function

Private Function InitAccountCurrency(ByVal strCode As String, ByVal strFile As String) As Boolean
    Dim i As Integer
    Dim intFileNum As Integer
    Dim strIDStr As String
    Dim strAC As String
    Dim recC As rdoResultset, strSql As String
    
    InitAccountCurrency = False
    On Error GoTo ErrHandle
    intFileNum = FreeFile
    Open strFile For Binary As #intFileNum
    strAC = String(LOF(intFileNum), " ")
    Get #intFileNum, 1, strAC
    Do Until strAC = ""
        strIDStr = StringOut(strAC, Chr(9))
        If strCode = StringOut(strIDStr, "=") Then
            Exit Do
        Else
            strIDStr = ""
        End If
    Loop
    Close #intFileNum
    If strIDStr = "" Then GoTo ErrHandle
    mstrCurID = Split(strIDStr)
    For i = 0 To UBound(mstrCurID)
        strSql = "SELECT lngCurrencyID FROM Currencys WHERE strCurrencyCode='" & mstrCurID(i) & "'"
        Set recC = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
        If Not recC.EOF Then
            mstrCurID(i) = recC("lngCurrencyID")
        Else
            recC.Close
            GoTo ErrHandle
        End If
        recC.Close
    Next i
    InitAccountCurrency = True
ErrHandle:
End Function

Public Property Get getID() As Long
    getID = mlngAccountID
End Property

Public Function AddCard(Optional strName As String = "", Optional lngTypeID As _
    Long = 0, Optional intModal As Integer = 0, Optional lngNatureID As Long = 0, _
    Optional ByVal IsList As Boolean = False) As Long
    mblnIsChanged = False
    mlngAccountID = 0
    mblnIsNew = True
    Caption = "新增会计科目"
    InitCard lngTypeID, strName, lngNatureID
    mblnIsList = IsList
    Show intModal
    AddCard = mlngAccountID
End Function

Private Function DeleteAccountCurrency(ByVal lngID As Long) As Boolean
    Dim strSql As String
    
    strSql = "DELETE FROM AccountCurrency WHERE lngAccountID=" & lngID
    DeleteAccountCurrency = gclsBase.ExecSQL(strSql)
End Function

'删除指定的科目
Public Function DelCard(ByVal lngID As Long, Optional lnghWnd As Long = 0, Optional blnIsShow As Boolean = True) As Boolean
    Dim strSql As String, recAcn As rdoResultset
    Dim strCode As String, strName As String
    
    If lngID < 1 Then
        DelCard = True
        Exit Function
    End If

    gclsBase.BaseWorkSpace.BeginTrans
    On Error GoTo ErrHandle
    DelCard = False
    
    strSql = "SELECT * FROM Account WHERE lngAccountID=" & lngID
    Set recAcn = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recAcn.EOF Then
        DelCard = True
        GoTo ErrHandle
    Else
        strCode = recAcn!strAccountCode
        strName = recAcn!strAccountName
        If recAcn!blnIsDetail = 0 Then
            If blnIsShow Then
                ShowMsg lnghWnd, "“" & strCode & " " & strName & "”" & "会计科目不是末级科目,不能删除!", _