frmemployeetype.frm

金算盘软件代码

        End If
    End If
End Sub

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

Private Function InitCard(Optional strName As String = "") As Boolean
     Dim recEmployeeType As rdoResultset, strSql As String
    
    mblnIsInit = True
    InitCard = True
    mlngPCodeID = 0
    mblnPIsDetail = False
    If Not mblnIsNew Then
        strSql = "SELECT * FROM EmployeeType WHERE lngEmployeeTypeID=" _
            & mlngEmployeeTypeID
        Set recEmployeeType = gclsBase.BaseDB.OpenResultset(strSql, _
            rdOpenStatic)
        With recEmployeeType
            txtEType(0).Text = !strEmployeeTypeCode
            mstrLastCode = !strEmployeeTypeCode
            txtEType(1).Text = !strEmployeeTypeName
            mstrLastName = !strEmployeeTypeName
            mblnIsDetail = (!blnIsDetail = 1)
            mintOldLevel = !intLevel
            mstrOldFullName = !strFullName
            mstrNotes = Format(!strNotes, "@;;")
        End With
        recEmployeeType.Close
    Else
        txtEType(1).Text = ""
        txtEType(0).Text = Trim(strName)
        mstrNotes = ""
    End If
    mblnIsInit = False
End Function

Private Function CodeCheck() As Integer
    Dim recEmployeeType As rdoResultset
    Dim strCode As String, strSql As String
    Dim strPre As String
    
    strCode = Trim$(txtEType(0).Text)
    If Not mblnIsNew Then
        If mstrLastCode = strCode Then
            strPre = CodePrefix(mstrOldFullName)
            If strPre = "" Then
                mstrFullName = Trim$(txtEType(1).Text)
            Else
                mstrFullName = strPre & "-" & Trim$(txtEType(1).Text)
            End If
            CodeCheck = 1
            Exit Function
        Else
            strSql = "SELECT * FROM EmployeeType WHERE strEmployeeTypeCode LIKE '" _
                & mstrLastCode & "*'"
            Set recEmployeeType = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If Not recEmployeeType.EOF Then
                recEmployeeType.MoveLast
                If Len(Trim$(recEmployeeType!strEmployeeTypeCode)) + Len(strCode) - _
                    Len(mstrLastCode) > 16 Then
                    CodeCheck = -3   '编码超长
                    Exit Function
                End If
            End If
            recEmployeeType.Close
        End If
    End If

    strSql = "SELECT * FROM EmployeeType WHERE strEmployeeTypeCode='" & strCode & "'"
    Set recEmployeeType = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recEmployeeType.EOF Then
        CodeCheck = -2             '当前编码已存在
        mlngPCodeID = recEmployeeType!lngEmployeeTypeID
        mblnPIsDetail = recEmployeeType!blnIsDetail
        mstrFullName = CodePrefix(Trim$(recEmployeeType!strFullName)) & "-" _
            & Trim$(txtEType(1).Text)
        Exit Function
    End If
    recEmployeeType.Close

    strPre = CodePrefix(strCode)
    If strPre <> "" Then
        strSql = "SELECT * FROM EmployeeType WHERE strEmployeeTypeCode='" & strPre & "'"
        Set recEmployeeType = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If recEmployeeType.EOF Then
            CodeCheck = -1           '上级编码不存在
            Exit Function
        Else
'            mintLevel = stringCount(strCode, "-") + 1
            mblnIsDetail = True
            mstrFullName = Trim$(recEmployeeType!strFullName) & "-" _
                & Trim$(txtEType(1).Text)
            mlngPCodeID = recEmployeeType!lngEmployeeTypeID
            mblnPIsDetail = recEmployeeType!blnIsDetail
        End If
        recEmployeeType.Close
    Else
'        mintLevel = 1
        mblnIsDetail = True
        mstrFullName = Trim$(txtEType(1).Text)
        mlngPCodeID = 0
        mblnPIsDetail = False
    End If
    CodeCheck = 1
End Function

Private Function MergeCode() As Boolean
    MergeCode = False
    If Not DisplaceActivity("Employee", "lngEmployeeTypeID", mlngPCodeID, mlngEmployeeTypeID) Then Exit Function
    If Not DisplaceActivity("Salary", "lngEmployeeTypeID", mlngPCodeID, mlngEmployeeTypeID) Then Exit Function
    If Not DisplaceActivity("SalaryAccount", "lngEmployeeTypeID", mlngPCodeID, mlngEmployeeTypeID) Then Exit Function
    MergeCode = True
End Function

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

Private Sub txtEType_Change(Index As Integer)
    Dim strErr As String
    
    If Index = 0 Then
        strErr = "'""|?`~ !^*"
    Else
        strErr = "'""|?`~-!^*"
    End If
    If ContainErrorChar(txtEType(Index).Text, strErr) Then
        BKKEY txtEType(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 recEmployeeType As rdoResultset
    Dim strSql As String, strFullName As String, strNotes As String
    
    strSql = "SELECT * FROM EmployeeType WHERE lngEmployeeTypeID=" & lngPID
    Set recEmployeeType = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    With recEmployeeType
    mblnIsDetail = False
    mintLevel = !intLevel
    mstrStartDate = !strStartDate
    mstrCode = !strEmployeeTypeCode
    mstrName = !strEmployeeTypeName
    strFullName = !strFullName
    strNotes = !strNotes
    End With
    recEmployeeType.Close
    
    intLevel = stringCount(Trim(txtEType(0).Text), "-") + 1
    strSql = "UPDATE EmployeeType SET strEmployeeTypeCode='" & Trim(txtEType(0).Text) _
        & "',strEmployeeTypeName='" & Trim(txtEType(1).Text) & "',strFullName='" & mstrFullName _
        & "',intLevel =" & intLevel & ",strNotes='" & IIf(mstrNotes = "", " ", mstrNotes) & "',strStartDate='" _
        & Format(Date, "YYYY-MM-DD") & "' WHERE lngEmployeeTypeID=" & lngPID
    TransActivity = gclsBase.ExecSQL(strSql)
    If TransActivity Then
        mstrFullName = strFullName
        mstrNotes = strNotes
    End If
End Function

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