frmaccountlistcard.frm

金算盘软件代码

Public Function AddCard(Optional strName As String = "", Optional lngTypeID As _
    Long = 0, Optional intModal As Integer = 0, Optional lngNatureID As Long = 0) As Long
    mblnIsChanged = False
    mlngAccountID = 0
    mblnIsNew = True
    cmdOK(2).Default = True
    Caption = "新增会计科目"
    InitCard lngTypeID, strName, lngNatureID
    If Me.WindowState = 1 Then Me.WindowState = 0
    Show intModal
    AddCard = mlngAccountID
    Refresh
    ZOrder 0
    Unload MsgForm
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) As Boolean
    Dim strSql As String, recAcn As rdoResultset
    Dim strCode As String, strName As String
    
    gclsBase.BaseWorkSpace.BeginTrans
    On Error GoTo ErrHandle
    DelCard = False
    
    strSql = "SELECT * FROM Account WHERE lngAccountID=" & lngID
    Set recAcn = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If recAcn.EOF Then
        GoTo ErrHandle
    Else
        strCode = recAcn!strAccountCode
        strName = recAcn!strAccountName
        If recAcn!blnIsDetail = 0 Then
            ShowMsg 0, "“" & strCode & " " & strName & "”" & "会计科目不是末级科目,不能删除!", _
               vbExclamation + MB_TASKMODAL, "删除会计科目"
            GoTo ErrHandle
        End If
    End If
    recAcn.Close
    
    If AccountIsUsed(lngID) Then
        ShowMsg 0, "“" & strCode & " " & strName & "”" & "会计科目已被使用,不允许删除!", _
              vbExclamation + MB_TASKMODAL, "删除会计科目"
        GoTo ErrHandle
    End If
    
    If ShowMsg(0, "你确实要删除" & "“" & strCode & " " & strName & "”" & "会计科目吗?", _
              vbQuestion + vbYesNo + MB_TASKMODAL, "删除会计科目") = vbNo Then
        GoTo ErrHandle
    End If
    
    strSql = "DELETE FROM Account WHERE lngAccountID=" & lngID
    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    If Not DeleteAccountCurrency(lngID) Then GoTo ErrHandle
    If Not ChangeHigherCardDetail("Account", "strAccountCode", strCode) Then GoTo ErrHandle
    
    gclsBase.BaseWorkSpace.CommitTrans
    DelCard = True
    'gclsSys.SendMessage Me.hwnd, Message.msgAccount
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollbackTrans
End Function
'新增(LNGID=0)或编辑科目
Public Sub EditCard(ByVal lngID As Long, Optional intModal As Integer = 0)
    
    If Not CheckIDUsed("Account", "lngAccountID", lngID) Then
        ShowMsg 0, "该会计科目不存在,不能进行修改!", vbExclamation + MB_TASKMODAL, "修改会计科目"
        'gclsSys.SendMessage Me.hwnd, Message.msgAccount
        Unload Me
        Exit Sub
    Else
        mblnIsChanged = False
        cmdOK(0).Default = True
        mlngAccountID = lngID
        mblnIsNew = False
        Caption = "修改会计科目"
        InitCard
        If Me.WindowState = 1 Then Me.WindowState = 0
        Show intModal
        Refresh
        ZOrder 0
    End If
    Unload MsgForm
End Sub
'根据ID返回名称或根据名称返回ID
Private Function AccountX(Value, Index As Integer)
    Dim i As Integer
    
'    If Value = "" Then
'        AccountX = 6
'        Exit Function
'    End If
'    If Value = 6 Then
'        AccountX = ""
'        Exit Function
'    End If
'
'    If Format$(Value, "@;;;") = "" Then
'        AccountX = "  "
'        Exit Function
'    End If
'
    If TypeName(Value) = "String" Then
        If Value = "" Then
            AccountX = 6
            Exit Function
        End If
        For i = 0 To cboAccount(Index).ListCount - 1
            If cboAccount(Index).list(i) = Value Then
                AccountX = cboAccount(Index).ItemData(i)
                cboAccount(Index).ListIndex = i
                Exit Function
            End If
        Next i
    Else
        If Value = 6 Then
            AccountX = ""
            Exit Function
        End If
        For i = 0 To cboAccount(Index).ListCount - 1
            If Abs(cboAccount(Index).ItemData(i)) = Abs(Value) Then
                AccountX = cboAccount(Index).list(i)
                cboAccount(Index).ListIndex = i
                Exit Function
            End If
        Next i
    End If
End Function
'指定的科目是否已使用
Private Function AccountIsUsed(ByVal lngID As Long) As Boolean
    
    AccountIsUsed = True
    If CheckIDUsed("Customer", "lngARAccountID", lngID) Then Exit Function
    If CheckIDUsed("customer", "lngAPAccountID", lngID) Then Exit Function
    If CheckIDUsed("AccountBalance", "lngAccountID", lngID) Then Exit Function
    If CheckIDUsed("ActivityDetail", "lngAccountID", lngID) Then Exit Function
    If CheckIDUsed("ARAPInit", "lngAccountID", lngID) Then Exit Function
    If CheckIDUsed("BankDetail", "lngAccountID", lngID) Then Exit Function
    If CheckIDUsed("BankInit", "lngAccountID", lngID) Then Exit Function
    If CheckIDUsed("Tax", "lngPurchaseTaxAccountID", lngID) Then Exit Function
    If CheckIDUsed("Tax", "lngSaleTaxAccountID", lngID) Then Exit Function
    If CheckIDUsed("TransVoucherDetail", "lngAccountID", lngID) Then Exit Function
    If CheckIDUsed("VoucherDetail", "lngAccountID", lngID) Then Exit Function
    'If CheckIDUsed("AccountCurrency", "lngAccountID", lngid) Then Exit Function
    AccountIsUsed = False
End Function

Private Sub InitCard(Optional ByVal lngTypeID As Long = -1, _
    Optional strName As String = "", Optional lngNatureID As Long = 0)
    Dim recAccount As rdoResultset, recAcntType As rdoResultset
    Dim strSql As String, i As Integer, blnModifyProperty As Boolean
    
    mblnIsInit = True
    If Not mblnIsNew Then
        Caption = "修改会计科目"
        cmdOK(2).Visible = False
    End If
    
    cboAccount(0).Enabled = True
    cboAccount(1).Enabled = True
    cboAccount(0).Clear
    cboAccount(1).Clear
    cboAccount(1).AddItem "现金", 0
    cboAccount(1).ItemData(cboAccount(1).NewIndex) = 1
    cboAccount(1).AddItem "银行", 1
    cboAccount(1).ItemData(cboAccount(1).NewIndex) = 2
    cboAccount(1).AddItem "应收", 2
    cboAccount(1).ItemData(cboAccount(1).NewIndex) = 3
    cboAccount(1).AddItem "应付", 3
    cboAccount(1).ItemData(cboAccount(1).NewIndex) = 4
    cboAccount(1).AddItem "存货", 4
    cboAccount(1).ItemData(cboAccount(1).NewIndex) = 5
    cboAccount(1).AddItem "其它", 5
    mblnSelCur = False
    mlngPCodeID = 0
    mblnPIsDetail = False
    mblnPIsInActive = False
'    cboAccount(1).ItemData(cboAccount(1).NewIndex) = 6
'    cboAccount(1).AddItem "    ", 6
    strSql = "SELECT * FROM AccountType"
    Set recAcntType = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    Do Until recAcntType.EOF          'ItemData的值表示ID
        cboAccount(0).AddItem recAcntType("strAccountTypeName")
        cboAccount(0).ItemData(cboAccount(0).NewIndex) = _
            recAcntType!lngAccountTypeID * recAcntType!intDirection
        recAcntType.MoveNext
    Loop
    recAcntType.Close
    
    If Not mblnIsNew Then
        strSql = "SELECT * FROM Account WHERE lngAccountID=" & mlngAccountID
        Set recAccount = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
        txtAccount(0).Text = recAccount("strAccountCode")
        txtAccount(1).Text = recAccount("strAccountName")
        mstrLastCode = recAccount("strAccountCode")
        mstrOldFullName = Trim$(recAccount("strFullName"))
        mblnIsDetail = (recAccount("blnIsDetail") = 1)
        cboAccount(0).Text = AccountX(recAccount("lngAccountTypeID"), 0)
        If recAccount("lngAccountNatureID") <> 6 Then
            cboAccount(1).Text = AccountX(recAccount("lngAccountNatureID"), 1)
        End If
        mtxtAccountNature = cboAccount(1).Text
        txtAccount(2).Text = Format$(recAccount("strQuantityUnit"), "@;;;")
        chkQuantity.Value = recAccount("blnIsQuantity")
        mintOldLevel = recAccount("intLevel")
        If recAccount!intLevel <> 1 Then
            cboAccount(0).Enabled = False
           ' cboAccount(1).Enabled = False
        End If
        optDirection(0).Value = (recAccount("intDirection") = 1)
        optDirection(1).Value = Not optDirection(0).Value
        'mblnIsInit = recAccount("blnIsMultCurrency")
        optCheck(2).Value = recAccount("blnIsMultCurrency")
        optCheck(1).Value = recAccount("blnIsAllCurrency")
        chkSuit.Value = recAccount("blnIsCalcExchange")
        If optCheck(0).Value = True Then
           chkSuit.Enabled = False
        Else
           chkSuit.Enabled = True
        End If
        chkAid(0).Value = recAccount("blnIsCustomer")
        chkAid(1).Value = recAccount("blnIsDepartment")
        chkAid(2).Value = recAccount("blnIsEmployee")
        chkAid(3).Value = recAccount("blnIsJob")
        chkAid(4).Value = recAccount("blnIsClass1")
        chkAid(5).Value = recAccount("blnIsClass2")
        chkStop.Value = recAccount("blnIsInActive")
        recAccount.Close
        If CodeIsDetail("Account", "strAccountCode", txtAccount(0).Text) Then
            mblnAcntNEdit = Not NatureAllowEdit(mlngAccountID, blnModifyProperty)
            cboAccount(1).Enabled = Not mblnAcntNEdit
        Else
'           cboAccount(1).ListIndex = 5
           cboAccount(1).Enabled = False
        End If
'        bytModifyProperty = PropertyAllowEdit(mlngAccountID)
        If Not blnModifyProperty Then
            Label1(2).Enabled = False
            chkQuantity.Value = 0
            chkQuantity.Enabled = False
'        Else
'            Label1(2).Enabled = True
'            chkQuantity.Value = 0
'            chkQuantity.Enabled = True
        End If
    Else
        For i = 0 To 5
            chkAid(i).Value = Unchecked
        Next i
        chkQuantity.Value = Unchecked
        For i = 0 To cboAccount(0).ListCount - 1
            If Abs(cboAccount(0).ItemData(i)) = lngTypeID Then Exit For
        Next i
        If i < cboAccount(0).ListCount Then
            cboAccount(0).ListIndex = i
        Else
            cboAccount(0).ListIndex = 0
        End If
        mblnAcntNEdit = False
'        If lngTypeID Mod 3 = 1 Then
'            optDirection(0).Value = True
'        Else
'            optDirection(1).Value = True
'        End If
        If lngNatureID <> 0 Then
            cboAccount(1).ListIndex = lngNatureID - 1
        End If
        optCheck(0).Value = True
        chkSuit.Enabled = False
        chkStop.Value = 0
        mstrOldFullName = ""
        txtAccount(1).Text = ""
        txtAccount(0).Text = strName
    End If
    InitVar mblnIsNew
    'chkSuit.Enabled = Frame1.Enabled
    mintDirectionOld = mintDirection
    mstrPre = CodePrefix(txtAccount(0).Text)
    chkQuantity_Click
    SendKeys "%{C}"
    mblnIsInit = False
End Sub

Private Function NatureAllowEdit(lngID As Long, ByRef PropertyAllowEdit As Boolean) As Boolean
    Dim recX As rdoResultset, strSql As String
    
    NatureAllowEdit = False
    PropertyAllowEdit = False
    strSql = "SELECT * FROM Setting WHERE strSection='特殊科目' AND InStr(" _
        & "'待处理流动资产损益 分期收款发出商品 分期收款结算折扣 汇兑损益 " _
        & "领用出库 其它出库 其它入库 商品采购 受托代销商品款 委托代销商品 " _
        & "委托加工 自制入库 固定资产 累计折旧',strKey,1)>0 " _
        & "AND strSetting='" & lngID & "'"
    Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If Not recX.EOF Then
        recX.Close
        Exit Function
    End If
    recX.Close
    
    #If conVersionType <> 16 Then
        strSql = "SELECT * FROM ItemNature WHERE lngSaleAccountID=" & lngID _
            & " OR lngCostAccountID=" & lngID & " OR lngStockAccountID=" & lngID _
            & " OR lngDiffAccountID=" & lngID & " OR lngStockTaxAccountID=" & lngID
        Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
        If Not recX.EOF Then
            recX.Close
            Exit Function
        End If
        recX.Close
    #End If
    
    PropertyAllowEdit = True
    strSql = "SELECT * FROM Customer WHERE lngARAccountID=" & lngID & " OR " _
        & "lngAPAccountID=" & lngID
    Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If Not recX.EOF Then
        recX.Close
        Exit Function
    End If
    recX.Close
    
    NatureAllowEdit = True
End Function

'1--不能修改外币、数量、辅助  2--不能修改数量、辅助  9--都可以修改
'Private Function PropertyAllowEdit(lngID As Long) As Byte
'    Dim recX As rdoResultset, strSql As String
'
'    strSql = "SELECT * FROM ItemNature WHERE lngSaleAccountID=" & lngID _
'        & " OR lngCostAccountID=" & lngID
'    Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
'    If Not recX.EOF Then
'        PropertyAllowEdit = 1
'        recX.Close
'        Exit Function
'    End If
'    recX.Close
'    strSql = "SELECT * FROM Setting WHERE strSection='特殊科目' AND strKey='商品采购' " _
'        & "AND CLng(strSetting)=" & lngID
'    Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
'    If Not recX.EOF Then
'        PropertyAllowEdit = 2
'        recX.Close
'        Exit Function
'    End If
'    recX.Close
'    PropertyAllowEdit = 9
'End Function
'
Private Sub InitVar(blnNew As Boolean) ', FullName As String)
    If Not blnNew Then
        mstrCode = Trim$(txtAccount(0).Text)
        mstrName = Trim$(txtAccount(1).Text)
    Else
        mstrCode = ""
        mstrName = ""
    End If
'    mstrFullName = FullName
    mblnSelCur = False
End Sub

Private Function SaveCard() As Boolean
    Dim blnMerge As Boolean
    Dim intResult As Integer    '编码检查结果:1--合法 -1--上级编码不存在 -2--编码已存在 -3--编码超长
    Dim recAccount As rdoResultset, strSql As String
    Dim i As Integer, intIsInActive As Integer, intIsDetail As Integer, intCheckQuantity As Integer
    Dim intAid(5) As Integer, intAllCur As Integer, intPartCur As Integer, intSuit As Integer
    
    
'    If Not mblnIsChanged Then
'        SaveCard = True
'        Exit Function
'    End If
'
    On Error GoTo ErrHandle
    
    SaveCard = False
    
    gclsBase.BaseWorkSpace.BeginTrans
    
    If Trim$(txtAccount(0).Text) = "" Then
        ShowMsg 0, "科目编码不能为空!", vbExclamation + MB_TASKMODAL, Caption
        txtAccount(0).SetFocus
        GoTo ErrHandle
    End If
    
    If InStr(1, txtAccount(0).Text, mstrCode & "-") = 1 And Not mblnIsNew Then
        ShowMsg 0, "科目不能修改为自己的下级科目!", vbExclamation + MB_TASKMODAL, Caption
        txtAccount(0).SetFocus
        GoTo ErrHandle