class2card.frm

金算盘软件代码

    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload Me
    End If
End Sub

Private Sub Form_Paint()
  FrameBox Me.hwnd, 150, 150, 3650, 2050
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Dim intMsgReturn As Integer, strMess As String
    
    If UnloadMode <> vbFormControlMenu Then Exit Sub
    If Trim(txtClass(0).Text & txtClass(1).Text) = "" Then Exit Sub
    If mblnIsChanged Then
        If mblnIsNew Then
            strMess = "您要保存新增的项目"
            If txtClass(0).Text <> "" Then
                strMess = strMess & "“" & txtClass(0).Text & "”"
            End If
            If txtClass(1).Text <> "" Then
                strMess = strMess & "“" & txtClass(1).Text & "”"
            End If
            strMess = strMess & "吗？"
        Else
            strMess = "“" & txtClass(0).Text & "”" & " " _
                & "“" & txtClass(1).Text & "”项目已被修改，是否保存？"
        End If
        intMsgReturn = ShowMsg(hwnd, strMess, vbQuestion + vbYesNoCancel, Caption)
        If intMsgReturn = vbYes Then
            Cancel = Not SaveCard
        ElseIf intMsgReturn = vbCancel Then
            Cancel = True
        End If
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
'    frmClassItemList.IsShowCard = False
    Utility.UnLoadFormResPicture Me
    mblnIsChanged = False
End Sub

Private Function InitCard(Optional strName As String = "") As Boolean
     Dim recClass2 As rdoResultset, strSql As String
    
    InitCard = True
    mblnIsInit = True
    mlngPCodeID = 0
    mblnPIsDetail = False
    mblnPIsInActive = False
    If Not mblnIsNew Then
        strSql = "SELECT * FROM Class2 WHERE lngClassID=" _
            & mlngClassID
        Set recClass2 = gclsBase.BaseDB.OpenResultset(strSql, _
            rdOpenStatic)
        With recClass2
            txtClass(0).Text = !strClassCode
            mstrLastCode = !strClassCode
            txtClass(1).Text = !strClassName
            mstrLastName = !strClassName
            mstrNotes = Format(!strNotes, "@;;")
            mintOldLevel = !intLevel
            mblnIsInActive = !blnIsInActive
            mblnIsDetail = !blnIsDetail
            mstrOldFullName = !strFullName
            chkInActive.Value = IIf(!blnIsInActive, 1, 0)
        End With
        recClass2.Close
    Else
        txtClass(1).Text = ""
        txtClass(0).Text = Trim(strName)
        mstrNotes = ""
        chkInActive.Value = 0
    End If
    mblnIsInit = False
End Function

Public Function MergeCode(ByVal lngPID As Long, ByVal lngID As Long) As Boolean
    MergeCode = False
    If Not MergeAccountDaily(lngPID, lngID, "lngClassID2") Then Exit Function
    If Not DisplaceActivity("ActivityDetail", "lngClassID2", lngPID, lngID) Then Exit Function
    If gclsBase.ControlAccount Then
        If Not DisplaceActivity("ARAPInit", "lngClassID2", lngPID, lngID) Then Exit Function
    Else
        If Not DisplaceActivity("ARAPInit1", "lngClassID2", lngPID, lngID) Then Exit Function
    End If
    If Not MergeBudgetBalance(lngPID, lngID, "lngClassID2") Then Exit Function
    If Not DisplaceActivity("CostPrice", "lngClassID2", lngPID, lngID) Then Exit Function
    If Not DisplaceActivity("ItemActivity", "lngClassID2", lngPID, lngID) Then Exit Function
    If Not DisplaceActivity("PurchaseOrder", "lngClassID2", lngPID, lngID) Then Exit Function
    If Not DisplaceActivity("SaleOrder", "lngClassID2", lngPID, lngID) Then Exit Function
    If Not DisplaceActivity("StockTaking", "lngClassID2", lngPID, lngID) Then Exit Function
    If Not DisplaceActivity("TransVoucherDetail", "lngClassID2", lngPID, lngID) Then Exit Function
    If Not DisplaceActivity("VoucherDetail", "lngClassID2", lngPID, lngID) Then Exit Function
    MergeCode = True
End Function

Private Function SaveCard(Optional blnByAdd As Boolean = False) As Boolean
    Dim blnMerge As Boolean     'NEW--转移业务  EDIT--合并代码
    Dim intResult As Integer    '编码检查结果:1--合法 -1--上级编码不存在 -2--编码已存在 -3--编码超长
    Dim recClass2 As rdoResultset, strSql As String
    
    On Error GoTo ErrHandle
    
    SaveCard = False
    
    gclsBase.BaseWorkSpace.BeginTrans
    
    If Trim$(txtClass(0).Text) = "" Then
        If Not blnByAdd Then
            ShowMsg hwnd, "项目编码不能为空!", vbExclamation, Caption
            txtClass(0).SetFocus
        End If
        GoTo ErrHandle
    End If
    
    If InStr(1, txtClass(0).Text, mstrLastCode & "-") <> 0 And Not mblnIsNew Then
        ShowMsg hwnd, "项目不能修改为自己的下级项目!", vbExclamation, Caption
        txtClass(0).SetFocus
        GoTo ErrHandle
    End If
    If InStr(1, mstrLastCode, txtClass(0).Text & "-") <> 0 And Not mblnIsNew Then
        ShowMsg hwnd, "项目不能修改为自己的上级项目!", vbExclamation, Caption
        txtClass(0).SetFocus
        GoTo ErrHandle
    End If
    If Trim$(txtClass(1).Text) = "" Then
        If Not blnByAdd Then
            ShowMsg hwnd, "项目名称不能为空!", vbExclamation, Caption
            txtClass(1).SetFocus
        End If
        GoTo ErrHandle
    End If
    
    intResult = CodeCheck("Class2", "strClassCode", "lngClassID", _
        mblnIsNew, txtClass(0).Text, txtClass(1).Text, mstrLastCode, _
        mstrOldFullName, mstrFullName, mlngPCodeID, mblnPIsDetail, mblnPIsInActive, mblnIsDetail)
    If intResult = -1 Then
        If mblnIsNew Then
            If Not blnByAdd Then
                ShowMsg hwnd, "“" & Trim$(txtClass(0).Text) & "“的上级项目" _
                    & "不存在,请先增加上级项目”" & CodePrefix(txtClass(0).Text) _
                    & "“", vbExclamation, Caption
            End If
        Else
            ShowMsg hwnd, "“" & Trim$(txtClass(0).Text) & "“的上级项目" _
                & "不存在,请重新修改项目”" _
                & Trim$(txtClass(0).Text) & "“", vbExclamation, Caption
        End If
        txtClass(0).SetFocus
        GoTo ErrHandle
    ElseIf intResult = -2 Then
        If mblnIsNew Then
            If Not blnByAdd Then
                ShowMsg hwnd, "项目编码“" & Trim$(txtClass(0).Text) _
                    & "”已经存在,请重新录入项目编码", vbExclamation, Caption
                txtClass(0).SetFocus
            End If
            GoTo ErrHandle
        Else
            If Not mblnPIsDetail Or (mblnIsInActive <> mblnPIsInActive) Or Not mblnIsDetail Then
                ShowMsg hwnd, "项目“" & mstrLastCode & "”与项目“" _
                    & Trim$(txtClass(0).Text) & "”不能合并,请重新修改项目编码“" _
                    & Trim$(txtClass(0).Text) & "“", vbExclamation, Caption
                mlngPCodeID = 0
                txtClass(0).SetFocus
                GoTo ErrHandle
            Else
                If ShowMsg(hwnd, "是否将项目“" & mstrLastCode & "”与“" _
                    & Trim$(txtClass(0).Text) & "”进行合并?", vbQuestion + vbYesNo, _
                     Caption) = vbNo Then
                    txtClass(0).SetFocus
                    GoTo ErrHandle
                Else
                    blnMerge = True
                End If
            End If
        End If
    ElseIf intResult = -3 Then
        If Not blnByAdd Then
            ShowMsg hwnd, "项目编码太长,请重新修改编码!", vbExclamation, Caption
            txtClass(0).SetFocus
        End If
        GoTo ErrHandle
    Else
        If mblnIsNew And mblnPIsDetail Then
            If CodeIsUsed(mlngPCodeID) Then
                If Not blnByAdd Then
                    If ShowMsg(hwnd, "项目“" & CodePrefix(txtClass(0).Text) & "”是一个已经发生业务的末级项目," _
                        & "是否在该项目下新增明细项目“" & Trim$(txtClass(0).Text) & "”," _
                        & "并将发生的所有业务转到新增的明细项目?", vbQuestion + vbYesNo, _
                        Caption) = vbNo Then
                        txtClass(0).SetFocus
                        GoTo ErrHandle
                    Else
                        blnMerge = True
                    End If
                Else
                    blnMerge = True
                End If
            End If
        End If
    End If
    
'    If CheckSameName("Class2", "strClassCode", txtClass(0).Text, _
'        "strClassName", txtClass(1).Text, "lngClassID", _
'        IIf(mblnIsNew, 0, mlngClassID)) Then
'        If Not blnByAdd Then
'            ShowMsg hWnd, "已有同级项目使用了" & "“" & txtClass(1).Text & "“" & _
'                ",请重新录入项目名称!", _
'                vbExclamation, Caption
'            txtClass(1).SetFocus
'        End If
'        recClass2.Close
'        GoTo ErrHandle
'    End If
    mstrCode = Trim(txtClass(0).Text)
    mstrName = Trim(txtClass(1).Text)
    mblnIsInActive = (chkInActive.Value = vbChecked)
    mblnIsDetail = True
    mstrStartDate = Format(gclsBase.BaseDate, "YYYY-MM-DD")
    mintLevel = stringCount(Trim(txtClass(0).Text), "-") + 1
    If mblnIsNew Then
        If mblnPIsDetail Then
            If blnMerge Then    '上级编码是已使用的末级编码,合并业务
                If Not TransActivity(mlngPCodeID) Then GoTo ErrHandle
            Else
                strSql = "UPDATE Class2 SET blnIsDetail=0 WHERE " _
                    & "lngClassID=" & mlngPCodeID
                If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
            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 Class2 SET blnIsInActive=1 WHERE " _
                    & "lngClassID=" & mlngPCodeID
                If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
            Else
                mblnIsInActive = False
            End If
        End If
        mlngClassID = GetNewID("Class2")
        strSql = "INSERT INTO Class2(lngClassID,strClassCode," _
            & "strClassName,strFullName,blnIsInActive,intLevel,blnIsDetail," _
            & "strStartDate) VALUES(" & mlngClassID & ",'" & mstrCode & "','" _
            & mstrName & "','" & mstrFullName & "'," & IIf(mblnIsInActive, 1, 0) & "," _
            & mintLevel & "," & IIf(mblnIsDetail, 1, 0) & ",'" & mstrStartDate & "')" '插入数据库
        gclsBase.BaseDB.Execute strSql
        If blnMerge Then mlngClassID = mlngPCodeID
'        If Not mblnIsInActive Then
'            strSql = "SELECT * FROM Class2 WHERE strClassCode='" & Trim(txtClass(0).Text) & "'"
'            Set recClass2 = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
'            mlngClassID = recClass2!lngClassID
'            recClass2.Close
'        End If
    Else
        '进行编码合并
        If blnMerge Then
            If Not MergeCode(mlngPCodeID, mlngClassID) Then GoTo ErrHandle
            strSql = "DELETE FROM Class2 WHERE lngClassID=" & mlngClassID
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
        Else
            strSql = "UPDATE Class2 SET strClassCode='" & mstrCode _
                & "',strClassName='" & mstrName & "',strFullName='" & mstrFullName _
                & "',blnIsInActive=" & IIf(mblnIsInActive, 1, 0) & ",intLevel =" & mintLevel _
                & " WHERE lngClassID=" & mlngClassID
            gclsBase.BaseDB.Execute strSql
            If Not ChangeLowerCardCodeAndFullName("Class2", "strClassCode", _
                "strFullName", "lngClassID", mstrLastCode, mstrOldFullName, mstrCode, _
                mstrFullName, mintOldLevel, mintLevel) Then GoTo ErrHandle
            If mblnIsInActive Then      '本级停用时改变下级的停用属性
                If Not ChangeLowerActive("Class2", "strClassCode", mstrCode) _
                    Then GoTo ErrHandle
            End If
            If mblnPIsDetail Then
                strSql = "UPDATE Class2 SET blnIsDetail=0 WHERE lngClassID=" _
                    & mlngPCodeID
                If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
            End If
        End If
        If Not ChangeHigherCardDetail("Class2", "strClassCode", mstrLastCode) Then GoTo ErrHandle
    End If
    If Not mblnIsInActive And mblnPIsInActive Then  '本级是活动时改变上级的停用属性
        If Not ChangeHigherActive("Class2", "strClassCode", mstrCode) _
            Then GoTo ErrHandle
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    SaveCard = True
    mblnIsChanged = False
    gclsSys.SendMessage Me.hwnd, Message.msgClass2
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollBacktrans
    If InStr(Err.Description, "违反唯一约束条件") > 0 Then
        If Not blnByAdd Then
            ShowMsg hwnd, "已有同级项目使用了" & "“" & txtClass(1).Text & "“" & _
                ",请重新录入项目名称!", vbExclamation, Caption
            txtClass(1).SetFocus
        End If
    End If
End Function

Private Sub txtClass_Change(Index As Integer)
    Dim strErr As String
    
    If Index = 0 Then
        strErr = "'""|?`~ !^*"
    Else
        strErr = "'""|?`~-!^*"
    End If
    If ContainErrorChar(txtClass(Index).Text, strErr) Then
        BKKEY txtClass(Index).hwnd
    End If
    If Not mblnIsInit Then mblnIsChanged = True
End Sub

Private Function TransActivity(ByVal lngPID As Long) As Boolean
    Dim intLevel As Integer
    Dim recClass2 As rdoResultset
    Dim strSql As String, strFullName As String, strNotes As String
    
    strSql = "SELECT * FROM Class2 WHERE lngClassID=" & lngPID
    Set recClass2 = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    With recClass2
    mblnIsDetail = False
'    mblnIsInActive = !blnIsInActive
    mintLevel = !intLevel
    mstrStartDate = !strStartDate
    mstrCode = !strClassCode
    mstrName = !strClassName
    strFullName = !strFullName
    strNotes = !strNotes
    End With
    recClass2.Close
    
    intLevel = stringCount(Trim(txtClass(0).Text), "-") + 1
    strSql = "UPDATE Class2 SET strClassCode='" & Trim(txtClass(0).Text) _
        & "',strClassName='" & Trim(txtClass(1).Text) & "',strFullName='" & mstrFullName _
        & "',blnIsInActive=" & chkInActive.Value & ",intLevel =" & intLevel _
        & ",strNotes='" & IIf(mstrNotes = "", " ", mstrNotes) & "',strStartDate='" _
        & Format(gclsBase.BaseDate, "YYYY-MM-DD") & "' WHERE lngClassID=" & lngPID
    TransActivity = gclsBase.ExecSQL(strSql)
    If TransActivity Then
        mstrFullName = strFullName
        mstrNotes = strNotes
    End If
End Function

Private Sub txtClass_KeyPress(Index As Integer, KeyAscii As Integer)
    If Index = 0 Then
        If InStr("'""|?`~!^ *", Chr(KeyAscii)) > 0 Then KeyAscii = 0
    Else
        If InStr("'""|?`~-!^*", Chr(KeyAscii)) > 0 Then KeyAscii = 0
    End If
End Sub