frmaccountlistcard.frm

金算盘软件代码

    End If
    If InStr(1, mstrLastCode, txtAccount(0).Text & "-") <> 0 And Not mblnIsNew Then
        ShowMsg hwnd, "科目不能修改为自己的上级科目!", vbExclamation, Caption
        txtAccount(0).SetFocus
        GoTo ErrHandle
    End If
    If Trim$(txtAccount(1).Text) = "" Then
        ShowMsg 0, "科目名称不能为空!", vbExclamation + MB_TASKMODAL, Caption
        txtAccount(1).SetFocus
        GoTo ErrHandle
    End If
    If chkQuantity.Value = 1 And Trim(txtAccount(2).Text) = "" Then
        ShowMsg 0, "“" & Trim$(txtAccount(0).Text) & " " & Trim$(txtAccount(1).Text) & _
          "”" & "科目选择了数量核算,计量单位不能为空!", vbExclamation + MB_TASKMODAL, Caption
        txtAccount(2).SetFocus
        GoTo ErrHandle
    End If
    
    If Not mblnIsNew Then
        strSql = "select strKey from setting where strSection='" & "特殊科目" _
            & "' and strSetting='" & mlngAccountID & "'"
        Set recAccount = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recAccount.EOF Then
           If recAccount.rdoColumns(0) = "商品采购" Then
              If chkQuantity.Value = 1 Then
                 ShowMsg Me.hwnd, "该科目已在特殊科目的商品采购中使用，不能选择该科目的数量和辅助核算！", _
                           vbExclamation + MB_TASKMODAL, Me.Caption
                 chkQuantity.SetFocus
                 'SendKeys "%Q"
                 GoTo ErrHandle
              End If
              For i = 0 To 5
                  If chkAid(i).Value = 1 Then
                     ShowMsg Me.hwnd, "该科目已在特殊科目的商品采购中使用，不能选择该科目的数量和辅助核算！", _
                           vbExclamation + MB_TASKMODAL, Me.Caption
                     chkAid(i).SetFocus
                     'SendKeys "%E"
                     GoTo ErrHandle
                  End If
              Next
           Else
              Select Case recAccount.rdoColumns(0)
                     Case "分期收款发出商品", "委托代销商品", "委托加工科目", "受托代销商品款"
                          If cboAccount(1).Enabled = True Then
                             If Trim(mtxtAccountNature) <> Trim(cboAccount(1).Text) Then
                                ShowMsg Me.hwnd, "该科目的科目性质在特殊科目中已经使用，不能修改该科目的科目性质！", _
                                  vbExclamation + MB_TASKMODAL, Me.Caption
                                SendKeys "%P"
                                GoTo ErrHandle
                             End If
                          End If
              End Select
           End If
        End If
    End If
        
    intResult = CodeCheck("Account", "strAccountCode", "lngAccountID", _
        mblnIsNew, txtAccount(0).Text, txtAccount(1).Text, mstrLastCode, _
        mstrOldFullName, mstrFullName, mlngPCodeID, mblnPIsDetail, _
        mblnPIsInActive, mblnIsDetail)
    If intResult = -1 Then
        If mblnIsNew Then
            ShowMsg 0, "“" & Trim$(txtAccount(0).Text) & "”的上级科目" _
                & "不存在,请先增加上级科目“" & CodePrefix(txtAccount(0).Text) & "”", vbExclamation + MB_TASKMODAL, Caption
        Else
            ShowMsg 0, "“" & Trim$(txtAccount(0).Text) & "”的上级科目" _
                & "不存在,请重新修改科目“" _
                & Trim$(txtAccount(0).Text) & "”", vbExclamation + MB_TASKMODAL, Caption
        End If
        txtAccount(0).SetFocus
        GoTo ErrHandle
    ElseIf intResult = -2 Then
        If mblnIsNew Then
            ShowMsg 0, "科目编码“" & Trim$(txtAccount(0).Text) _
                & "”已经存在,请重新录入科目编码", vbExclamation + MB_TASKMODAL, Caption
            txtAccount(0).SetFocus
            GoTo ErrHandle
        Else
            If Not CodeIsDetail("Account", "strAccountCode", mstrCode) Or _
                   Not CodeIsDetail("Account", "strAccountCode", txtAccount(0).Text) Or _
                   Not ActiveIsSame("Account", "strAccountCode", mstrCode, txtAccount(0).Text) Then
                ShowMsg 0, "科目“" & mstrCode & "”与科目“" _
                    & Trim$(txtAccount(0).Text) & "”不能合并,请重新修改科目编码“" _
                    & Trim$(txtAccount(0).Text) & "”", vbExclamation + MB_TASKMODAL, Caption
                txtAccount(0).SetFocus
                GoTo ErrHandle
            Else
                If ShowMsg(0, "是否将科目“" & Trim$(txtAccount(0).Text) & "”与“" _
                    & mstrCode & "”进行合并?", vbQuestion + vbYesNo + MB_TASKMODAL, _
                     Caption) = vbNo Then
                    txtAccount(0).SetFocus
                    GoTo ErrHandle
                    'Exit Function
                Else
                    blnMerge = True
                End If
            End If
        End If
    ElseIf intResult = -3 Then
        ShowMsg 0, "科目编码太长,请重新修改编码!", vbExclamation + MB_TASKMODAL, Caption
        txtAccount(0).SetFocus
        GoTo ErrHandle
    Else
'        If mblnIsNew Then
'           If mblnPisActive = True Then
'              ShowMsg 0, "当前科目的上级科目已被停用，不能增加当前科目！", vbExclamation _
'                        + MB_SYSTEMMODAL, Me.Caption
'              txtAccount(0).SetFocus
'              GoTo ErrHandle
'           End If
'        End If
        If mblnIsNew And mblnPIsDetail Then
            If AccountIsUsed(mlngPCodeID) Then
                If ShowMsg(0, "科目“" & CodePrefix(txtAccount(0).Text) & "”是一个已经发生业务的末级科目," _
                    & "是否在该科目下新增明细科目“" & Trim$(txtAccount(0).Text) & "”," _
                    & "并将发生的所有业务转到新增的明细科目?", vbQuestion + vbYesNo + MB_TASKMODAL, _
                    Caption) = vbNo Then
                    txtAccount(0).SetFocus
                    GoTo ErrHandle
                Else
                    blnMerge = True
                End If
            End If
        End If
    End If
    
    If CheckSameName("Account", "strAccountCode", txtAccount(0).Text, _
          "strAccountName", txtAccount(1).Text, "lngAccountID", _
          IIf(mblnIsNew, 0, mlngAccountID)) Then
        ShowMsg 0, "已有同级科目使用了" & "“" & txtAccount(1).Text & "”" & ",请重新录入科目名称!", _
            vbExclamation + MB_TASKMODAL, Caption
        txtAccount(1).SetFocus
        recAccount.Close
        GoTo ErrHandle
    End If
    mstrCode = txtAccount(0).Text
    mstrName = txtAccount(1).Text
    mblnIsInActive = (chkStop.Value = vbChecked)
    mblnIsDetail = True
    mstrStartDate = Format(gclsBase.BaseDate, "YYYY-MM-DD")
    mintLevel = stringCount(Trim(txtAccount(0).Text), "-") + 1
    mlngTypeID = Abs(AccountX(cboAccount(0).Text, 0))
    mlngNatureID = AccountX(cboAccount(1).Text, 1)
    mintDirection = IIf(optDirection(0).Value, 1, -1)
    mblnAllCur = optCheck(1).Value
    mblnPartCur = optCheck(2).Value
    mblnSuit = (chkSuit.Value = 1)
    mblnChkQuantity = (chkQuantity.Value = 1)
    mstrUnit = txtAccount(2).Text
    For i = 0 To 5
        mblnAid(i) = (chkAid(i).Value = 1)
    Next i
    If mblnIsNew Then
        If mblnPIsDetail Then
            If blnMerge Then    '上级编码是已使用的末级编码,合并业务
                If Not TransActivity(mlngPCodeID) Then GoTo ErrHandle
            Else
                If mblnPIsDetail Then
                    strSql = "UPDATE Account SET blnIsDetail=0,blnIsCustomer=0," _
                        & "blnIsDepartment=0,blnIsEmployee=0,blnIsJob=0," _
                        & "blnIsClass1=0,blnIsClass2=0,blnIsQuantity=0," _
                        & "strQuantityUnit='',blnIsMultCurrency=0," _
                        & "blnIsAllCurrency=0,blnIsCalcExchange=0,lngAccountNatureid=6 " _
                        & "WHERE lngAccountID=" & mlngPCodeID
                    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
                    If Not DeleteAccountCurrency(mlngPCodeID) Then GoTo ErrHandle
                End If
            End If
        End If
        If Not mblnIsInActive And mblnPIsInActive And mlngPCodeID <> 0 Then
            If ShowMsg(hwnd, "上级部门已经被停用,是否启用上级部门？", _
                vbQuestion + vbYesNo, Caption) = vbNo Then
                mblnIsInActive = True
                 strSql = "UPDATE Account SET blnIsInActive=1 WHERE " _
                    & "lngAccountID=" & mlngPCodeID
                If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
            Else
                mblnIsInActive = False
            End If
        End If
        mlngAccountID = GetNewID("Account")
        intIsInActive = IIf(mblnIsInActive, 1, 0)
        intIsDetail = IIf(mblnIsDetail, 1, 0)
        intAllCur = IIf(mblnAllCur, 1, 0)
        intPartCur = IIf(mblnPartCur, 1, 0)
        intSuit = IIf(mblnSuit, 1, 0)
        intCheckQuantity = IIf(mblnChkQuantity, 1, 0)
        For i = 0 To 5
            intAid(i) = IIf(mblnAid(i), 1, 0)
        Next i
        strSql = "INSERT INTO Account(lngAccountID,strAccountCode,strAccountName,strFullName," _
            & "blnIsInActive,intLevel,blnIsDetail,lngAccountTypeID,intDirection," _
            & "lngAccountNatureID,blnIsCustomer,blnisDepartment,blnIsEmployee," _
            & "blnIsJob,blnIsClass1,blnIsClass2,blnIsQuantity,strQuantityUnit," _
            & "blnIsMultCurrency,blnIsAllCurrency,blnIsCalcExchange,strStartDate)" _
            & " VALUES(" & mlngAccountID & ",'" & mstrCode & "','" & mstrName & "','" _
            & mstrFullName & "'," & intIsInActive & "," & mintLevel & "," & intIsDetail _
            & "," & mlngTypeID & "," & mintDirection & "," & mlngNatureID _
            & "," & intAid(0) & "," & intAid(1) & "," & intAid(2) & "," _
            & intAid(3) & "," & intAid(4) & "," & intAid(5) & "," _
            & intCheckQuantity & ",'" & mstrUnit & " '," & intPartCur & "," _
            & intAllCur & "," & intSuit & ",'" & mstrStartDate & "')"
        If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
'        Strsql = "SELECT * FROM Account WHERE strAccountCode='" & txtAccount(0).Text & "'"
'        Set recAccount = gclsBase.BaseDB.OpenResultset(Strsql, rdOpenForwardOnly)
'        mlngAccountID = recAccount!lngAccountID
'        recAccount.Close
    Else
        '进行编码合并
        If blnMerge Then
            If Not frmAccountCard.MergeCode(mlngPCodeID, mlngAccountID) Then GoTo ErrHandle
            strSql = "DELETE FROM Account WHERE lngAccountID=" & mlngAccountID
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
        Else
            intAllCur = IIf(optCheck(1).Value, 1, 0)
            intPartCur = IIf(optCheck(2).Value, 1, 0)
            strSql = "UPDATE Account SET strAccountCode='" & Trim$(txtAccount(0).Text) _
                & "',strAccountName='" & Trim$(txtAccount(1).Text) & "',strFullName='" _
                & mstrFullName & "',blnIsInActive=" & chkStop.Value _
                & ",intlevel=" & mintLevel _
                & ",lngAccountTypeID=" & Abs(AccountX(cboAccount(0).Text, 0)) & ",intDirection=" _
                & IIf(optDirection(0).Value, 1, -1) & ",lngAccountNatureID=" _
                & AccountX(cboAccount(1).Text, 1) & ",blnIsCustomer=" _
                & chkAid(0).Value & ",blnisDepartment=" & chkAid(1).Value & ",blnIsEmployee=" _
                & chkAid(2).Value & ",blnIsJob=" & chkAid(3).Value & ",blnIsClass1=" _
                & chkAid(4).Value & ",blnIsClass2=" & chkAid(5).Value & ",blnIsQuantity=" _
                & chkQuantity.Value & ",strQuantityUnit='" _
                & txtAccount(2).Text & " ',blnIsMultCurrency=" _
                & intPartCur & ",blnIsAllCurrency=" & intAllCur _
                & ",blnIsCalcExchange=" & chkSuit.Value _
                & " WHERE lngAccountID=" & mlngAccountID
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
            If Not optCheck(2).Value Then
                If Not DeleteAccountCurrency(mlngAccountID) Then GoTo ErrHandle
            End If
            If mintDirection <> mintDirectionOld Then
                If Not ChangeBalanceDirection Then GoTo ErrHandle
            End If
            UpdateVoucherAccount '调整凭证的借贷方编码
            If Not ChangeLowerCardCodeAndFullName("Account", "strAccountCode", _
                "strFullName", "lngAccountID", mstrLastCode, mstrOldFullName, mstrCode, _
                mstrFullName, mintOldLevel, mintLevel) Then GoTo ErrHandle
            If mblnIsInActive Then      '本级停用时改变下级的停用属性
                If Not ChangeLowerActive("Account", "strAccountCode", mstrCode) _
                    Then GoTo ErrHandle
            End If
        End If
        If mblnPIsDetail Then
            strSql = "UPDATE Account SET blnIsDetail=0,blnIsCustomer=0," _
                & "blnIsDepartment=0,blnIsEmployee=0,blnIsJob=0," _
                & "blnIsClass1=0,blnIsClass2=0,blnIsQuantity=0," _
                & "strQuantityUnit='',blnIsMultCurrency=0," _
                & "blnIsAllCurrency=0,blnIsCalcExchange=0,lngAccountNatureid=6 " _
                & "WHERE lngAccountID=" & mlngPCodeID
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
            If Not DeleteAccountCurrency(mlngPCodeID) Then GoTo ErrHandle
        End If
        If Not ChangeHigherCardDetail("Account", "strAccountCode", mstrLastCode) Then GoTo ErrHandle
    End If
    If Not mblnIsInActive And mblnPIsInActive Then  '本级是活动时改变上级的停用属性
        If Not ChangeHigherActive("Account", "strAccountCode", mstrCode) _
            Then GoTo ErrHandle
    End If
    '重新选择了核算币种后更新科目币种表
    If optCheck(2).Value And mblnSelCur Then
'        Dim i As Integer
        strSql = "DELETE FROM AccountCurrency WHERE lngAccountID=" & mlngAccountID
        If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
        For i = 0 To UBound(frmSelCur.arrcurid)
            strSql = "INSERT INTO AccountCurrency(lngAccountID,lngCurrencyID) " _
                & "VALUES(" & mlngAccountID & "," & frmSelCur.arrcurid(i) & ")"
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
        Next i
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    SaveCard = True
    InitVar False
    gclsSys.SendMessage Me.hwnd, Message.msgAccount
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollbackTrans
End Function

'余额方向改变后，改变ACCOUNTBALANCE
Private Function ChangeBalanceDirection() As Boolean
    Dim strSql As String
    
    strSql = "UPDATE AccountBalance SET dblUnVoucherInit=-1*dblUnVoucherInit," _
        & "dblUnCheckedInit=-1*dblUnCheckedInit,dblCheckedInit=-1*dblCheckedInit," _
        & "dblPostedInit=-1*dblPostedInit,dblCurrencyUnVoucherInit=-1*dblCurrencyUnVoucherInit," _
        & "dblCurrencyUnCheckedInit=-1*dblCurrencyUnCheckedInit,dblCurrencyCheckedInit=-1*dblCurrencyCheckedInit," _
        & "dblCurrencyPostedInit=-1*dblCurrencyPostedInit,dblQuantityUnVoucherInit=-1*dblQuantityUnVoucherInit," _
        & "dblQuantityUnCheckedInit=-1*dblQuantityUnCheckedInit,dblQuantityCheckedInit=-1*dblQuantityCheckedInit," _
        & "dblQuantityPostedInit=-1*dblQuantityPostedInit WHERE lngAccountID=" & mlngAccountID
    ChangeBalanceDirection = gclsBase.ExecSQL(strSql)

End Function

'转移业务到新的下级
Private Function TransActivity(lngPID As Long) As Boolean
    Dim intLevel As Integer, intAllCur As Integer, intPartCur As Integer
    Dim recAccount As rdoResultset
    Dim strSql As String, strFullName As String
    
    strSql = "SELECT * FROM Account WHERE lngAccountID=" & lngPID
    Set recAccount = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    With recAccount
    mblnIsDetail = False
'    mblnIsInActive = !blnIsInActive
    mintLevel = !intLevel
    mstrStartDate = !strStartDate
    mstrCode = !strAccountCode
    mstrName = !strAccountName
    strFullName = !strFullName
    mlngTypeID = !lngAccountTypeID
'    mlngNatureID = !lngAccountNatureid
    mintDirection = !intDirection
'    mblnAllCur = !blnIsAllCurrency
'    mblnPartCur = !blnIsMultCurrency
'    mblnSuit = !blnIsCalcExchange
'    mblnChkQuantity = !blnIsQuantity
'    mstrUnit = !strQuantityUnit
'    mblnAid(0) = !blnIsCustomer
'    mblnAid(1) = !blnIsDepartment
'    mblnAid(2) = !blnIsEmployee
'    mblnAid(3) = !blnIsJob
'    mblnAid(4) = !blnIsClass1
'    mblnAid(5) = !blnIsClass2
    mlngNatureID = 6
    mblnAllCur = False
    mblnPartCur = False
    mblnSuit = False
    mblnChkQuantity = False
    mstrUnit = ""
    mblnAid(0) = False
    mblnAid(1) = False
    mblnAid(2) = False
    mblnAid(3) = False
    mblnAid(4) = False
    mblnAid(5) = False
    End With
    recAccount.Close
    
    intLevel = stringCount(Trim(txtAccount(0).Text), "-") + 1
    intAllCur = IIf(optCheck(1).Value, 1, 0)
    intPartCur = IIf(optCheck(2).Value, 1, 0)
    strSql = "UPDATE Account SET strAccountCode='" & Trim$(txtAccount(0).Text) _
        & "',strAccountName='" & Trim$(txtAccount(1).Text) & "',strFullName='" _
        & mstrFullName & "',blnIsInActive=" & chkStop.Value _
        & ",intlevel=" & intLevel & ",blnIsDetail=1,lngAccountTypeID=" _
        & Abs(AccountX(cboAccount(0).Text, 0)) & ",intDirection=" _
        & IIf(optDirection(0).Value, 1, -1) & ",lngAccountNatureID=" _
        & AccountX(cboAccount(1).Text, 1) & ",blnIsCustomer=" _
        & chkAid(0).Value & ",blnisDepartment=" _
        & chkAid(1).Value & ",blnIsEmployee=" _
        & chkAid(2).Value & ",blnIsJob=" _
        & chkAid(3).Value & ",blnIsClass1=" _
        & chkAid(4).Value & ",blnIsClass2=" _
        & chkAid(5).Value & ",blnIsQuantity=" _
        & chkQuantity.Value & ",strQuantityUnit='" _
        & txtAccount(2).Text & " ',blnIsMultCurrency=" _
        & intPartCur & ",blnIsAllCurrency=" & intAllCur _
        & ",blnIsCalcExchange=" & chkSuit.Value & ",strStartDate='" _
        & Format(gclsBase.BaseDate, "yyyy-mm-dd") & "' WHERE lngAccountID=" _
        & lngPID
    TransActivity = gclsBase.ExecSQL(strSql)
    If TransActivity Then mstrFullName = strFullName
End Function

Private Sub cboAccount_Click(Index As Integer)
    Dim intAcn As Integer, i As Integer
    
    If cboAccount(Index).ListIndex = -1 Then Exit Sub
    intAcn = cboAccount(Index).ItemData(cboAccount(Index).ListIndex)
    If Index = 0 Then
        If intAcn > 0 Then
            optDirection(0).Value = True
            optDirection(1).Value = False
        Else
            optDirection(0).Value = False
            optDirection(1).Value = True
        End If
    Else
        If intAcn < 5 Then '应收应付性质
            If intAcn = 3 Or intAcn = 4 Then
                chkAid(0).Value = 1
                chkAid(0).Enabled = False
                chkQuantity.Value = 0
                chkQuantity.Enabled = False
            Else
                chkAid(0).Value = 0
                chkAid(0).Enabled = True
'                chkQuantity.Value = 0
                chkQuantity.Enabled = True
            End If
            txtAccount(2).Text = ""
            Frame1.Enabled = True
            optCheck(0).Enabled = True
            optCheck(1).Enabled = True
            optCheck(2).Enabled = True