frmdepcardnew.frm

金算盘软件代码

    If intResult = -1 Then
        If Not blnByAdd Then
            If mblnIsNew Then
                ShowMsg hwnd, "“" & Trim$(txtDepartment(0).Text) & "“的上级部门" _
                    & "不存在,请先增加上级部门”" & CodePrefix(txtDepartment(0).Text) _
                        & "“", vbExclamation, Caption
            Else
                ShowMsg hwnd, "“" & Trim$(txtDepartment(0).Text) & "“的上级部门" _
                    & "不存在,请重新修改部门”" _
                    & Trim$(txtDepartment(0).Text) & "“", vbExclamation, Caption
            End If
            txtDepartment(0).SetFocus
        End If
        GoTo ErrHandle
    ElseIf intResult = -2 Then
        If mblnIsNew Then
            If Not blnByAdd Then
                ShowMsg hwnd, "部门编码“" & Trim$(txtDepartment(0).Text) _
                    & "”已经存在,请重新录入部门编码", vbExclamation, Caption
                txtDepartment(0).SetFocus
            End If
            GoTo ErrHandle
        Else
            If Not mblnPIsDetail Or (mblnIsInActive <> mblnPIsInActive) Or Not mblnIsDetail Then
                ShowMsg hwnd, "部门“" & mstrLastCode & "”与部门“" _
                    & Trim$(txtDepartment(0).Text) & "”不能合并,请重新修改部门编码“" _
                    & Trim$(txtDepartment(0).Text) & "“", vbExclamation, Caption
                mlngPCodeID = 0
                txtDepartment(0).SetFocus
                GoTo ErrHandle
            Else
                If ShowMsg(hwnd, "是否将部门“" & mstrLastCode & "”与“" _
                    & Trim$(txtDepartment(0).Text) & "”进行合并?", vbQuestion + vbYesNo, _
                     Caption) = vbNo Then
                    txtDepartment(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
            txtDepartment(0).SetFocus
        End If
        GoTo ErrHandle
    Else
        If mblnIsNew And mblnPIsDetail Then
            If CodeIsUsed(mlngPCodeID) Then
                If Not blnByAdd Then
                    If ShowMsg(hwnd, "部门“" & CodePrefix(txtDepartment(0).Text) & "”是一个已经发生业务的末级部门," _
                        & "是否在该部门下新增明细部门“" & Trim$(txtDepartment(0).Text) & "”," _
                        & "并将发生的所有业务转到新增的明细部门?", vbQuestion + vbYesNo, _
                        Caption) = vbNo Then
                        txtDepartment(0).SetFocus
                        GoTo ErrHandle
                    Else
                        blnMerge = True
                    End If
                Else
                    blnMerge = True
                End If
            End If
        End If
    End If
    
'    If CheckSameName("Department", "strDepartmentCode", txtDepartment(0).Text, _
'        "strDepartmentName", txtDepartment(1).Text, "lngDepartmentID", _
'        IIf(mblnIsNew, 0, mlngDepartmentID)) Then
'        If Not blnByAdd Then
'            ShowMsg hWnd, "已有同级部门使用了" & "“" & txtDepartment(1).Text & "“" & _
'                ",请重新录入部门名称!", _
'                vbExclamation, Caption
'            txtDepartment(1).SetFocus
'        End If
'        recDepartment.Close
'        GoTo ErrHandle
'    End If
    mstrCode = Trim(txtDepartment(0).Text)
    mstrName = Trim(txtDepartment(1).Text)
    mblnIsInActive = (chkStop.Value = vbChecked)
    mblnIsDetail = True
    mstrStartDate = Format(gclsBase.BaseDate, "YYYY-MM-DD")
    mintLevel = stringCount(Trim(txtDepartment(0).Text), "-") + 1
    If mblnIsNew Then
        If mblnPIsDetail Then
            If blnMerge Then    '上级编码是已使用的末级编码,合并业务
                If Not TransActivity(mlngPCodeID) Then GoTo ErrHandle
            Else
                strSql = "UPDATE Department SET blnIsDetail=0 WHERE " _
                    & "lngDepartmentID=" & 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, "上级部门已经被停用,是否启用上级部门？", _
                    vbQuestion + vbYesNo, Caption) = vbNo Then
                    mblnIsInActive = True
                     strSql = "UPDATE Department SET blnIsInActive=True WHERE " _
                        & "lngDepartmentID=" & mlngPCodeID
                    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
                Else
                    mblnIsInActive = False
                End If
            Else
                mblnIsInActive = False
            End If
        End If
        mlngDepartmentID = GetNewID("Department")
        strSql = "INSERT INTO department(lngDepartmentID,strdepartmentCode,strdepartmentName," _
            & "strFullName,blnIsInActive,intLevel,blnIsDetail,strNotes," _
            & "strStartDate) VALUES(" & mlngDepartmentID & ",'" & mstrCode & "','" & mstrName _
            & "','" & mstrFullName & "'," & IIf(mblnIsInActive, 1, 0) & "," _
            & mintLevel & "," & IIf(mblnIsDetail, 1, 0) & ",'" & IIf(mstrNotes = "", " ", mstrNotes) & "','" & mstrStartDate & "')" '插入数据库
        gclsBase.BaseDB.Execute strSql
        If blnMerge Then mlngDepartmentID = mlngPCodeID
'        If Not mblnIsInActive Then
'            strSql = "SELECT * FROM department WHERE strdepartmentCode='" & Trim(txtDepartment(0).Text) & "'"
'            Set recDepartment = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
'            mlngDepartmentID = recDepartment!lngDepartmentID
'            recDepartment.Close
'        End If
    Else
        '进行编码合并
        If blnMerge Then
            If Not MergeCode(mlngPCodeID, mlngDepartmentID) Then GoTo ErrHandle
            strSql = "DELETE FROM department WHERE lngdepartmentID=" & mlngDepartmentID
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
        Else
            strSql = "UPDATE department SET strdepartmentCode='" & mstrCode _
                & "',strdepartmentName='" & mstrName & "',strFullName='" & mstrFullName _
                & "',blnIsInActive=" & IIf(mblnIsInActive, 1, 0) & ",intLevel =" & mintLevel _
                & ",strNotes='" & IIf(mstrNotes = "", " ", mstrNotes) & "' WHERE lngdepartmentID=" & mlngDepartmentID
            gclsBase.BaseDB.Execute strSql
            If Not ChangeLowerCardCodeAndFullName("Department", "strDepartmentCode", _
                "strFullName", "lngDepartmentID", mstrLastCode, mstrOldFullName, mstrCode, _
                mstrFullName, mintOldLevel, mintLevel) Then GoTo ErrHandle
'            If Not ChangeLowerCardCodeAndFullName("department", "strdepartmentCode", _
                "strFullName", mstrLastCode, mstrLastName, mstrCode, mstrName, "lngdepartmentID") _
                    Then GoTo ErrHandle
            If mblnIsInActive Then      '本级停用时改变下级的停用属性
                If Not ChangeLowerActive("department", "strdepartmentCode", mstrCode) _
                    Then GoTo ErrHandle
            End If
            If mblnPIsDetail Then
                strSql = "UPDATE Department SET blnIsDetail=0 WHERE lngDepartmentID=" _
                    & mlngPCodeID
                If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
            End If
        End If
        If Not ChangeHigherCardDetail("department", "strdepartmentCode", mstrLastCode) Then GoTo ErrHandle
'        If Not UpdateFixedAlter Then GoTo ErrHandle
    End If
    If Not mblnIsInActive And mblnPIsInActive Then  '本级是活动时改变上级的停用属性
        If Not ChangeHigherActive("department", "strdepartmentCode", mstrCode) _
            Then GoTo ErrHandle
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    SaveCard = True
    mblnIsChanged = False
    gclsSys.SendMessage Me.hwnd, Message.msgDepartment
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollBacktrans
    If InStr(Err.Description, "违反唯一约束条件") > 0 Then
        If Not blnByAdd Then
            ShowMsg hwnd, "已有同级部门使用了" & "“" & txtDepartment(1).Text & "“" & _
                ",请重新录入部门名称!", vbExclamation, Caption
            txtDepartment(1).SetFocus
        End If
    End If
End Function

'Private Function UpdateFixedAlter() As Boolean
'    Dim lngFAID As Long, recFA As rdoResultset, strDep As String
'    Dim strOldDep As String, strNewDep As String, strSql As String
'
'    If Trim(mstrLastName) = Trim(txtDepartment(1).Text) _
'        And Trim(mstrLastCode) = Trim(txtDepartment(0).Text) Then
'        UpdateFixedAlter = True
'        Exit Function
'    End If
'    UpdateFixedAlter = False
'    strOldDep = mstrLastCode & " " & mstrLastName
'    strNewDep = Trim(txtDepartment(0).Text) & " " & Trim(txtDepartment(1).Text)
'    strSql = "SELECT * FROM FixedAlter WHERE InStr(strDepartmentStr,'" & strOldDep & "')>0"
'    Set recFA = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
'    Do Until recFA.EOF
'        lngFAID = recFA!lngFixedAlterID
'        strDep = Replace(recFA!strDepartmentStr, strOldDep, strNewDep)
'        strSql = "UPDATE FixedAlter SET strDepartmentStr='" & strDep & "' WHERE lngFixedAlterID=" & lngFAID
'        If Not gclsBase.ExecSQL(strSql) Then
'            recFA.Close
'            Exit Function
'        End If
'        recFA.MoveNext
'    Loop
'    UpdateFixedAlter = True
'End Function
'
Private Sub txtDepartment_Change(Index As Integer)
    Dim strErr As String
    
    If Index = 0 Then
        strErr = "'""|?`~!^*"
    Else
        strErr = "'""|?`~-!^*"
    End If
    If mblnIsInit Then
        If ContainErrorChar(txtDepartment(Index).Text, strErr) Then
            BKKEY txtDepartment(Index).hwnd, vbKeyEnd
            BKKEY txtDepartment(Index).hwnd
        End If
    Else
        mblnIsChanged = True
        If ContainErrorChar(txtDepartment(Index).Text, strErr) Then
            BKKEY txtDepartment(Index).hwnd
        End If
    End If
End Sub

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

Private Sub txtDepartment_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