frmprojectcard.frm

金算盘软件代码

        If recA.EOF Then
            ShowMsg hwnd, "项目核算必须是没有被停用，" _
                & "你选择的“" & lstText(2).Text & "”无效，请重新选择！", vbExclamation, Caption
            LstValid = False
            recA.Close
            lstText(2).SetFocus
            Exit Function
        End If
    End If
    LstValid = True
End Function

'Private Function ChangeHA(ByVal strCode As String) As Boolean
'    Dim recX As rdoResultset, strSql As String
'    Dim strPCode As String
'
'    ChangeHA = True
'    strPCode = CodePrefix(strCode)
'    If strPCode = "" Then Exit Function
'
'    strSql = "SELECT * FROM Project WHERE strProjectCode='" & strPCode & "'"
'    Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
'    If recX("blnDetail") = 0 Then
'        recX.Close
'        Exit Function
'    End If
'End Function
'
Private Function SaveCard(Optional ByVal blnByAdd As Boolean = False) As Boolean
    Dim blnMerge As Boolean, i As Integer   'NEW--转移业务  EDIT--合并代码
    Dim intResult As Integer    '编码检查结果:1--合法 -1--上级编码不存在 -2--编码已存在 -3--编码超长
    Dim recProject As rdoResultset, strSql As String
    Dim intIsDetail As Integer, intIsInActive As Integer
    Dim strFullName As String, strOldFullName As String
    Dim strUnit As String, strCloseDate As String
    Dim dblQ As Double, strNote As String
    
    On Error GoTo ErrHandle
    
    SaveCard = False
    
    gclsBase.BaseWorkSpace.BeginTrans
    
    If Trim$(txtInput(0).Text) = "" Then
        ShowMsg hwnd, mstrTitle & "编码不能为空!", vbExclamation, Caption
        sstProject.Tab = 0
        txtInput(0).SetFocus
        GoTo ErrHandle
    End If
    
    If InStr(1, txtInput(0).Text, mstrOldCode & "-") <> 0 And Not mblnIsNew Then
        ShowMsg hwnd, mstrTitle & "不能修改为自己的下级" & mstrTitle & "!", vbExclamation, Caption
        sstProject.Tab = 0
        txtInput(0).SetFocus
        GoTo ErrHandle
    End If
    If InStr(1, mstrOldCode, txtInput(0).Text & "-") <> 0 And Not mblnIsNew Then
        ShowMsg hwnd, mstrTitle & "不能修改为自己的上级" & mstrTitle & "!", vbExclamation, Caption
        sstProject.Tab = 0
        txtInput(0).SetFocus
        GoTo ErrHandle
    End If
    If Trim$(txtInput(1).Text) = "" Then
        ShowMsg hwnd, mstrTitle & "名称不能为空!", vbExclamation, Caption
        sstProject.Tab = 0
        txtInput(1).SetFocus
        GoTo ErrHandle
    End If
    If chkClose.Value = Checked And dteClose.Text = "" Then
        ShowMsg hwnd, "选择了关闭，则关闭日期不能为空!", vbExclamation, Caption
        sstProject.Tab = 0
        dteClose.SetFocus
        GoTo ErrHandle
    End If
'    If mblnIsNew Or mblnIsDetail Then
'        If lstText.Text = "" Then
'            ShowMsg hwnd, "末级工程，会计科目不能为空!", vbExclamation, Caption
'            sstProject.Tab = 0
'            lstText.SetFocus
'            GoTo ErrHandle
'        End If
'    End If
'    For i = 0 To 2
'        If lstText(i).Text = "" Then
'            mlngLstID(i) = 0
'        Else
'            mlngLstID(i) = lstText(i).ID
'        End If
'    Next i
'    If mlngLstID <> 0 Then
        If Not LstValid Then
'            lstText.SetFocus
            GoTo ErrHandle
        End If
'    End If
    
    intResult = CodeCheck("Project", "strProjectCode", "lngProjectID", _
        mblnIsNew, txtInput(0).Text, txtInput(1).Text, mstrOldCode, _
        mstrOldFullName, mstrFullName, mlngPCodeID, mblnPIsDetail, mblnPIsInActive, _
        mblnIsDetail)
    If intResult = -1 Then
        If mblnIsNew Then
            If Not blnByAdd Then
                ShowMsg hwnd, "“" & Trim$(txtInput(0).Text) & "”的上级" & mstrTitle _
                    & "不存在,请先增加上级" & mstrTitle & "“" & CodePrefix(txtInput(0).Text) & "”", _
                        vbExclamation, Caption
            End If
        Else
            ShowMsg hwnd, "“" & Trim$(txtInput(0).Text) & "”的上级" & mstrTitle _
                & "不存在,请重新修改" & mstrTitle & "“" _
                & Trim$(txtInput(0).Text) & "”", vbExclamation, Caption
        End If
        txtInput(0).SetFocus
        GoTo ErrHandle
    ElseIf intResult = -2 Then
        If mblnIsNew Then
            If Not blnByAdd Then
                ShowMsg hwnd, mstrTitle & "编码“" & Trim$(txtInput(0).Text) _
                    & "”已经存在,请重新录入" & mstrTitle & "编码", vbExclamation, Caption
                txtInput(0).SetFocus
            End If
            GoTo ErrHandle
        Else
            If Not mblnPIsDetail Or (mblnIsInActive <> mblnPIsInActive) Or Not mblnIsDetail Then
                ShowMsg hwnd, mstrTitle & "“" & mstrOldCode & "”与" & mstrTitle & "“" _
                    & Trim$(txtInput(0).Text) & "”不能合并,请重新修改" & mstrTitle & "编码“" _
                    & Trim$(txtInput(0).Text) & "”", vbExclamation, Caption
                mlngPCodeID = 0
                txtInput(0).SetFocus
                GoTo ErrHandle
            Else
                If ShowMsg(hwnd, "是否将" & mstrTitle & "“" & mstrOldCode & "”与“" _
                    & Trim$(txtInput(0).Text) & "”进行合并?", vbQuestion + _
                    vbYesNo, Caption) = vbNo Then
                    txtInput(0).SetFocus
                    GoTo ErrHandle
                Else
                    mdblOldBudgetAmount = 0
                    strSql = "UPDATE Project SET dblBudgetAmount=dblBudgetAmount+" _
                        & TxtToDouble(txtInput(3).Text) & " WHERE strProjectCode='" _
                        & Trim(txtInput(0).Text) & "'"
                    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
'                    If Not ChangeHA(mstrOldCode) Then GoTo ErrHandle
                    blnMerge = True
                End If
            End If
        End If
    ElseIf intResult = -3 Then
        If Not blnByAdd Then
            ShowMsg hwnd, mstrTitle & "编码太长,请重新修改编码!", vbExclamation, Caption
            txtInput(0).SetFocus
        End If
        GoTo ErrHandle
    Else
        If mblnIsNew And mblnPIsDetail Then
            If CodeUsed(mlngPCodeID) Then
                If Not blnByAdd Then
                    If ShowMsg(hwnd, mstrTitle & "" & CodePrefix(txtInput(0).Text) & "”是一个已经发生业务的末级" & mstrTitle & "," _
                        & "是否在该" & mstrTitle & "下新增明细" & mstrTitle & "“" & Trim$(txtInput(0).Text) & "”," _
                        & "并将发生的所有业务转到新增的明细" & mstrTitle & "?", vbQuestion + vbYesNo, _
                        Caption) = vbNo Then
                        txtInput(0).SetFocus
                        GoTo ErrHandle
                    Else
                        blnMerge = True
                    End If
                Else
                    blnMerge = True
                End If
            End If
        End If
    End If
    
'    If CheckSameName("Project", "strProjectCode", txtInput(0).Text, _
'        "strProjectName", txtInput(1).Text, "lngProjectID", _
'        IIf(mblnIsNew, 0, mlngProjectID)) Then
'        If Not blnByAdd Then
'            ShowMsg hWnd, "已有同级工程项目使用了" & "“" & txtInput(1).Text & "“" & _
'                ",请重新录入工程项目名称!", vbExclamation, Caption
'            txtInput(1).SetFocus
'        End If
'        recProject.Close
'        GoTo ErrHandle
'    End If
    mstrCode = Trim(txtInput(0).Text)
    mstrName = Trim(txtInput(1).Text)
    mstrPrincipal = IIf(txtInput(2).Text = "", " ", txtInput(2).Text)
    mdblBudgetAmount = TxtToDouble(txtInput(3).Text)
    mblnIsInActive = (chkPause.Value = vbChecked)
    If mblnIsNew Then mblnIsDetail = True
    mstrStartDate = Format(gclsBase.BaseDate, "YYYY-MM-DD")
    mintLevel = stringCount(Trim(txtInput(0).Text), "-") + 1
    strUnit = IIf(txtInput(4).Text = "", " ", txtInput(4).Text)
    strCloseDate = IIf(dteClose.Text = "", " ", dteClose.Text)
    dblQ = TxtToDouble(txtInput(5).Text)
    strNote = IIf(txtNotes.Text = "", " ", txtNotes.Text)
    If mstrCode <> mstrOldCode Then
        If Not ChangeHigherSum(mstrCode, mdblBudgetAmount) Then GoTo ErrHandle
        If Not mblnIsNew And stringCount(mstrOldCode, "-") > 0 Then
            If Not ChangeHigherSum(mstrOldCode, 0 - mdblOldBudgetAmount) Then GoTo ErrHandle
        End If
    Else
        If mdblBudgetAmount <> mdblOldBudgetAmount Then
            If Not ChangeHigherSum(mstrCode, mdblBudgetAmount - mdblOldBudgetAmount) Then GoTo ErrHandle
'            If Not mblnIsNew And stringCount(mstrOldCode, "-") > 0 Then
'                If Not ChangeHigherSum(mstrOldCode, 0 - mdblOldBudgetAmount) Then GoTo ErrHandle
'            End If
        End If
    End If
    If mblnIsNew Then
        If mblnPIsDetail Then
            If blnMerge Then    '上级编码是已使用的末级编码,合并业务
                If Not TransActivity(mlngPCodeID) Then GoTo ErrHandle
            Else
                strSql = "UPDATE Project SET blnIsDetail=0 WHERE " _
                    & "lngProjectID=" & mlngPCodeID
                If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
            End If
        End If
        If Not mblnIsInActive And mblnPIsInActive And mlngPCodeID <> 0 Then
            If Not blnByAdd Then
                If ShowMsg(hwnd, "上级" & mstrTitle & "已经被停用,是否启用上级" & mstrTitle & "？", _
                    vbQuestion + vbYesNo, Caption) = vbNo Then
                    mblnIsInActive = True
                     strSql = "UPDATE Project SET blnIsInActive=True WHERE " _
                        & "lngProjectID=" & mlngPCodeID
                    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
                Else
                    mblnIsInActive = False
                End If
            Else
                mblnIsInActive = False
            End If
        End If
        intIsDetail = IIf(mblnIsDetail, 1, 0)
        intIsInActive = IIf(mblnIsInActive, 1, 0)
        mlngProjectID = GetNewID("Project")
        strSql = "INSERT INTO Project(lngProjectID,strProjectCode,strProjectName,strFullName," _
            & "strPrincipal,lngAccountID,lngClassID1,lngClassID2,dblBudgetAmount,blnIsInActive," _
            & "intLevel,blnIsDetail,strStartDate,strUnit,dblQuantity,blnIsClosed,strCloseDate," _
            & "strNote) VALUES(" & mlngProjectID & ",'" & mstrCode & "','" & mstrName & "','" _
            & mstrFullName & "','" & mstrPrincipal & "'," & mlngLstID(0) & "," _
            & mlngLstID(1) & "," & mlngLstID(2) & "," & mdblBudgetAmount & "," & intIsInActive & "," _
            & mintLevel & "," & intIsDetail & ",'" & mstrStartDate & "','" & strUnit & "'," & dblQ _
            & "," & chkClose.Value & ",'" & strCloseDate & "','" & strNote & "')"   '插入数据库
        gclsBase.BaseDB.Execute strSql
    Else
        '进行编码合并
        If blnMerge Then
            If Not MergeCode Then GoTo ErrHandle
            strSql = "DELETE FROM Project WHERE lngProjectID=" & mlngProjectID
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
            If Not ChangeHigherSum(mstrOldCode, 0 - mdblBudgetAmount) Then GoTo ErrHandle
        Else
            intIsInActive = IIf(mblnIsInActive, 1, 0)
            strSql = "UPDATE Project SET strProjectCode='" & mstrCode _
                & "',strProjectName='" & mstrName & "',strPrincipal='" & mstrPrincipal _
                & "',lngAccountID=" & mlngLstID(0) _
                & ",lngClassID1=" & mlngLstID(1) & ",lngClassID2=" & mlngLstID(2) _
                & ",dblBudgetAmount=" & mdblBudgetAmount _
                & ",blnIsInActive=" & intIsInActive & ",intLevel =" & mintLevel _
                & ",strFullName='" & mstrFullName & "',strUnit='" & strUnit _
                & "',dblQuantity=" & dblQ & ",blnIsClosed=" & chkClose.Value _
                & ",strCloseDate='" & strCloseDate & "',strNote='" & strNote _
                & "' Where lngProjectID = " & mlngProjectID
            gclsBase.BaseDB.Execute strSql
            If Not ChangeLowerCardCodeAndFullName("Project", "strProjectCode", _
                "strFullName", "lngProjectID", mstrOldCode, mstrOldFullName, mstrCode, _
                mstrFullName, mintOldLevel, mintLevel) Then GoTo ErrHandle
            If mblnIsInActive Then      '本级停用时改变下级的停用属性
                If Not ChangeLowerActive("Project", "strProjectCode", mstrCode) _
                    Then GoTo ErrHandle
            End If
            If mblnPIsDetail Then
                strSql = "UPDATE Project SET blnIsDetail=0 WHERE lngProjectID=" _
                    & mlngPCodeID
                If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
            End If
        End If
        If Not ChangeHigherCardDetail("Project", "strProjectCode", mstrOldCode) Then GoTo ErrHandle
    End If
    If chkClose.Value = Checked Then
        strSql = "UPDATE ProjectOrder SET blnIsClosed=1,strCloseDate='" & strCloseDate _
            & "' WHERE lngProjectID=" & mlngProjectID
        If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
        strSql = "UPDATE Project SET blnIsClosed=1,strCloseDate='" & strCloseDate _
                & "' WHERE strProjectCode LIKE '" & mstrCode & "-%'" & " AND strProjectCode<>'" _
                & mstrCode & "'"
        If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    Else
        strSql = "UPDATE ProjectOrder SET blnIsClosed=0,strCloseDate=' '" _
            & " WHERE lngProjectID=" & mlngProjectID
        If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
        If Not ChangeHigherClose(mstrCode) Then GoTo ErrHandle
    End If
    If Not mblnIsInActive And mblnPIsInActive Then  '本级是活动时改变上级的停用属性
        If Not ChangeHigherActive("Project", "strProjectCode", mstrCode) _
            Then GoTo ErrHandle
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    SaveCard = True
    mblnIsChanged = False
    gclsSys.SendMessage Me.hwnd, Message.msgProject
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollBacktrans
    If InStr(Err.Description, "违反唯一约束条件") > 0 Then
        If Not blnByAdd Then
            ShowMsg hwnd, "已有同级" & mstrTitle & "使用了" & "“" & txtInput(1).Text & "“" & _
                ",请重新录入" & mstrTitle & "名称!", vbExclamation, Caption
            txtInput(1).SetFocus
        End If
    End If
End Function

Private Function ChangeHigherSum(ByVal strCode As String, ByVal dblSum As Double) As Boolean
    Dim strPCode As String, strSql As String, recP As rdoResultset, dblValue As Double