frmemployeelistcard.frm

金算盘软件代码

    If Trim$(lstText(0).Text) = "" Then
        ShowMsg hwnd, "职员所属部门不能为空！", vbExclamation, Caption
        lstText(0).SetFocus
        GoTo ErrHandle
    End If
    If Trim(lstText(1).Text) = "" Then
       ShowMsg hwnd, "职员类型不能为空！", vbExclamation, Caption
       lstText(1).SetFocus
       GoTo ErrHandle
    End If
'    If Trim(txtEmployee(5).Text) <> "" And strLen(Trim(txtEmployee(5).Text)) <> 6 Then
'        ShowMsg hwnd, " 邮政编码必须是6位！", vbExclamation, Caption
'        txtEmployee(5).SetFocus
'        SendKeys "{HOME}+{END}"
'        GoTo ErrHandle
'    End If
'    If Trim(lstText(2).Text) = "" Then
'       showmsg hwnd, "职员的文化程度不能为空！", vbExclamation, Caption
'       lstText(2).SetFocus
'       Exit Function
'    End If
'    If Trim(lstText(3).Text) = "" Then
'       showmsg hwnd, "职员的职务不能为空！", vbExclamation, Caption
'       lstText(3).SetFocus
'       GoTo ErrHandle
'    End If
    If Not CheckDate Then GoTo ErrHandle
    If chkStop(1).Value = 1 And Trim(lstText(4).Text) = "" Then
       ShowMsg hwnd, "职员的扣税标准不能为空！", vbExclamation, Caption
       lstText(4).SetFocus
       GoTo ErrHandle
    End If
    GetLstValue
    If Not LstIsValid Then GoTo ErrHandle
    intResult = CheckCode
    If intResult = -2 Then
        ShowMsg hwnd, "职员名称不能为重复,请重新录入！", vbExclamation, Caption
        txtEmployee(1).SetFocus
        SendKeys "{END}+{HOME}"
        GoTo ErrHandle
    End If
    If intResult = -1 Then
        If mblnIsNew Then
            ShowMsg hwnd, "职员编码“" & Trim(txtEmployee(0).Text) _
                & "”已经存在,请重新录入！", vbExclamation, Caption
            txtEmployee(0).SetFocus
            SendKeys "{END}+{HOME}"
            GoTo ErrHandle
        Else
            If ShowMsg(hwnd, "是否将职员“" & mstrEmployee & "”与“" _
                & txtEmployee(0).Text & " " & txtEmployee(1).Text & "”进行合并?", _
                vbQuestion + vbYesNo, Caption) = vbNo Then
                txtEmployee(0).SetFocus
                SendKeys "{END}+{HOME}"
                GoTo ErrHandle
            Else
                blnMergeCode = True
            End If
        End If
    End If
    
    strBill = IIf(txtEmployee(2).Text = "", " ", txtEmployee(2).Text)
    strOffice = IIf(txtEmployee(3).Text = "", " ", txtEmployee(3).Text)
    strHome = IIf(txtEmployee(4).Text = "", " ", txtEmployee(4).Text)
    strPost = IIf(txtEmployee(5).Text = "", " ", txtEmployee(5).Text)
    strAddr = IIf(txtEmployee(6).Text = "", " ", txtEmployee(6).Text)
    strBirthDay = IIf(dtmEmployee(0).Text = "", " ", dtmEmployee(0).Text)
    strInDay = IIf(dtmEmployee(1).Text = "", " ", dtmEmployee(1).Text)
    strOutDay = IIf(dtmEmployee(2).Text = "", " ", dtmEmployee(2).Text)
    If mstrNotes = "" Then mstrNotes = " "
    If mblnIsNew Then
        mlngEmployeeID = GetNewID("Employee")
        strSql = "INSERT INTO Employee(lngEmployeeID,strEmployeeCode,strEmployeeName," _
            & "blnIsInActive,blnIsMale,lngDepartmentID,lngEmployeeTypeID," _
            & "lngEducationID,blnIsPersonTax,lngPersonTaxTypeID,strBankCode," _
            & "strInDate,strOutDate,lngTitleID,strAddress," _
            & "strPostalCode,strOfficePhone,strHomePhone,strBirthdate," _
            & "strNotes,strStartDate) VALUES (" & mlngEmployeeID & ",'" _
            & txtEmployee(0).Text & "','" & txtEmployee(1).Text & "'," _
            & chkStop(0).Value & "," & cboSex.ListIndex _
            & "," & mlngLstID(0) & "," & mlngLstID(1) & "," _
            & mlngLstID(2) & "," & chkStop(1).Value _
            & "," & mlngLstID(4) & ",'" & strBill _
            & "','" & strInDay & "','" & strOutDay _
            & "'," & mlngLstID(3) & ",'" & strAddr _
            & "','" & strPost & "','" & strOffice _
            & "','" & strHome & "','" & strBirthDay _
            & "','" & mstrNotes & "','" & Format(gclsBase.BaseDate, "yyyy-mm-dd") & "')"
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
'            Strsql = "SELECT * FROM Employee WHERE strEmployeeCode='" & txtEmployee(0).Text & "'"
'            Set recEmployee = gclsBase.BaseDB.OpenResultset(Strsql, rdOpenForwardOnly)
'            mlngEmployeeID = recEmployee!lngEmployeeID
'            recEmployee.Close
    Else
        If blnMergeCode Then
            If Not MergeCode Then GoTo ErrHandle
            strSql = "DELETE FROM Employee WHERE lngEmployeeID=" & mlngEmployeeID
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
        End If
        strSql = "UPDATE Employee SET strEmployeeCode='" & txtEmployee(0).Text _
            & "',strEmployeeName='" & txtEmployee(1).Text & "',blnIsInActive=" _
            & chkStop(0).Value & ",blnIsMale=" & cboSex.ListIndex & "," _
            & "lngDepartmentID=" & mlngLstID(0) & ",lngEmployeeTypeID=" _
            & mlngLstID(1) & ",lngEducationID=" & mlngLstID(2) _
            & ",blnIsPersonTax=" & chkStop(1).Value & "," _
            & "lngPersonTaxTypeID=" & mlngLstID(4) & ",strBankCode='" _
            & strBill & "',strIndate='" & strInDay & "'," _
            & "strOutDate='" & strOutDay & "',lngTitleID=" & mlngLstID(3) _
            & ",strAddress='" & strAddr & "',strPostalCode='" _
            & strPost & " ',strOfficePhone='" & strOffice _
            & "',strHomePhone='" & strHome & "',strBirthDate='" _
            & strBirthDay & "', strNotes='" & mstrNotes _
            & "' WHERE lngEmployeeID=" & mlngEmployeeID
        If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    SaveCard = True
    gclsSys.SendMessage Me.hwnd, Message.msgEmployee
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollbackTrans
End Function

Private Function LstIsValid() As Boolean
    LstIsValid = False
    If Not ItemIsValid("Department", "lngDepartmentID", mlngLstID(0)) Then
        ShowMsg hwnd, "部门应该是末级，您选择的“" & lstText(0).Text _
            & "”无效，请重新选择！", vbExclamation, Caption
        lstText(0).SetFocus
        Exit Function
    End If
    If Not ItemIsValid("EmployeeType", "lngEmployeeTypeID", mlngLstID(1), False) Then
        ShowMsg hwnd, "职员类型应该是末级，您选择的“" & lstText(1).Text _
            & "”无效，请重新选择！", vbExclamation, Caption
        lstText(1).SetFocus
        Exit Function
    End If
    LstIsValid = True
End Function

Private Sub lstText_AddNew(Index As Integer)
    Dim lngID As Long
    
    Select Case Index
    Case 0
        lngID = frmDepartmentCard.AddCard(, 1)
    Case 1
        lngID = frmEmployeeType.AddCard(, 1)
    Case 2
        lngID = frmEducation.AddCard(, 1)
    Case 3
        lngID = frmWorkName.AddCard(, 1)
    Case 4
        lngID = frmTax.AddCard(, 1)
    End Select
    If lngID <> 0 Then mlngLstID(Index) = lngID
    mblnIsFirst(Index) = True
    lstText_GotFocus Index
    mblnIsChanged = True
End Sub

Private Sub lstText_Change(Index As Integer)
    If ContainErrorChar(lstText(Index).Text, "`~!@#$%^&*=+'"";:,./?|\") Then BKKEY lstText(Index).hwnd
End Sub

Private Sub lstText_Choose(Index As Integer)
    If Not mblnIsInit Then mblnIsChanged = True
    mlngLstID(Index) = lstText(Index).TextMatrix(lstText(Index).ReferRow, 1)
End Sub

Private Sub lstText_Delete(Index As Integer)
    
    Select Case Index
    Case 0
        If frmDepartmentCard.DelCard(mlngLstID(0), Me.hwnd) Then mlngLstID(Index) = 0
    Case 1
        If frmEmployeeType.DelCard(mlngLstID(1), Me.hwnd) Then mlngLstID(Index) = 0
    Case 2
        If frmEducation.DelCard(mlngLstID(2), Me.hwnd) Then mlngLstID(Index) = 0
    Case 3
        If frmWorkName.DelCard(mlngLstID(3), Me.hwnd) Then mlngLstID(Index) = 0
    Case 4
        If frmTax.DelCard(mlngLstID(4), Me.hwnd) Then mlngLstID(Index) = 0
    End Select
    mblnIsFirst(Index) = True
    lstText_GotFocus Index
    mblnIsChanged = True
End Sub

Private Sub lstText_Edit(Index As Integer)
    
     Select Case Index
     Case 0
         frmDepartmentCard.EditCard mlngLstID(0), 1, lstText(0).Text
     Case 1
         frmEmployeeType.EditCard mlngLstID(1), 1, lstText(1).Text
     Case 2
         frmEducation.EditCard mlngLstID(2), 1, lstText(2).Text
     Case 3
         frmWorkName.EditCard mlngLstID(3), 1, lstText(3).Text
     Case 4
         frmTax.EditCard mlngLstID(4), 1
    End Select
    If Trim(lstText(Index).Text) = "" Then mlngLstID(Index) = 0
    mblnIsChanged = True
    mblnIsFirst(Index) = True
    lstText_GotFocus Index
End Sub

Private Sub lstText_GotFocus(Index As Integer)
    If mblnIsNew Then
        cmdOK(2).Default = False
    Else
        cmdOK(0).Default = False
    End If
    If mblnIsFirst(Index) Then
        Select Case Index
            Case 0
                setlistbox lstText(Index), 8, mlngLstID(Index)
            Case 1
                setlistbox lstText(Index), 11, mlngLstID(Index)
            Case 2
                setlistbox lstText(Index), 9, mlngLstID(Index)
            Case 3
                setlistbox lstText(Index), 4, mlngLstID(Index)
            Case 4
                setlistbox lstText(Index), 10, mlngLstID(Index)
        End Select
        mblnIsFirst(Index) = False
    End If
End Sub

Private Sub lstText_ItemNotExist(Index As Integer)
    Dim iResponse As Integer, lngID As Long
    Dim recX As rdoResultset, strSql As String
    
    Select Case Index
    Case 0
        If frmMsgAdd.MsgAddShow(Caption, "部门列表中没有" & lstText(0).Text) = vbOK Then
            lngID = frmDepartmentCard.AddCard(lstText(0).Text, 1)
        Else
            lstText(Index).Text = ""
        End If
    Case 1
        If frmMsgAdd.MsgAddShow(Caption, "职员类型列表中没有" & lstText(1).Text) = vbOK Then
            lngID = frmEmployeeType.AddCard(lstText(1).Text, 1)
        End If
    Case 2
        iResponse = frmMsgQuickAdd.MsgAddShow(Caption, "文化程度列表中没有" & lstText(2).Text)
        If iResponse = vbOK Then
            lngID = frmEducation.AddCard(lstText(2).Text, 1)
        ElseIf iResponse = 0 Then
            strSql = "INSERT INTO Education (,lngEducationID,strEducationName) " _
                & "VALUES (" & GetNewID("Education") & ",'" & lstText(2).Text & "')"
            gclsBase.BaseDB.Execute strSql
            strSql = "SELECT * FROM Education WHERE strEducationName='" & lstText(2).Text & "'"
            Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
            lngID = recX!lngEducationID
            recX.Close
        Else
            lstText(Index).Text = ""
        End If
    Case 3
        iResponse = frmMsgQuickAdd.MsgAddShow(Caption, "职务编码列表中没有" & lstText(3).Text)
        If iResponse = vbOK Then
            lngID = frmWorkName.AddCard(lstText(3).Text, 1)
        ElseIf iResponse = 0 Then
            strSql = "INSERT INTO Title (lngTitleID,strTitleName) " _
                & "VALUES (" & GetNewID("Title") & ",'" & lstText(3).Text & "')"
            gclsBase.BaseDB.Execute strSql
            strSql = "SELECT * FROM Title WHERE strTitleName='" & lstText(3).Text & "'"
            Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
            lngID = recX!lngTitleID
            recX.Close
        Else
            lstText(Index).Text = ""
        End If
    Case 4
        If frmMsgAdd.MsgAddShow(Caption, "扣税标准列表中没有" & lstText(4).Text) = vbOK Then
            lngID = frmTax.AddCard(lstText(4).Text, 1)
        Else
            lstText(Index).Text = ""
        End If
    End Select
    If lngID <> 0 Then mlngLstID(Index) = lngID
    mblnIsChanged = True
    mblnIsFirst(Index) = True
    lstText_GotFocus Index
End Sub

Private Sub lstText_KeyUp(Index As Integer, KeyCode As Integer, Shift As Integer)
'    If KeyCode = vbKeyReturn Then SendKeys "{TAB}"
End Sub

Private Sub lstText_LostFocus(Index As Integer)
    If mblnIsNew Then
        cmdOK(2).Default = True
    Else
        cmdOK(0).Default = True
    End If
    BKKEY lstText(Index).hwnd, vbKeyHome
End Sub

Private Sub mclsMainControl_ChildActive()
    gclsSys.CurrFormName = Me.hwnd
End Sub

Private Sub mclsMainControl_EditShowList()
    ShowRelationList
End Sub

Private Sub txtEmployee_Change(Index As Integer)
    If mblnIsInit Then Exit Sub
    Select Case Index
    Case 1
        If ContainErrorChar(txtEmployee(1).Text, "'|`~?-$") Then BKKEY txtEmployee(1).hwnd
    Case 3, 4
        If Not ContainSpecifyChar(txtEmployee(Index).Text, "-0123456789()[]{}") _
            Or Left(txtEmployee(Index).Text, 1) = "-" Then BKKEY txtEmployee(Index).hwnd
    Case 5
        If Not ContainSpecifyChar(txtEmployee(5).Text) Then BKKEY txtEmployee(5).hwnd
    Case Else
        If ContainErrorChar(txtEmployee(Index).Text) Then BKKEY txtEmployee(Index).hwnd
    End Select
    mblnIsChanged = True
End Sub

Private Function IsContinue() As Boolean
    Dim lngResult As Long
    
    IsContinue = True
    If mblnIsChanged Then
        Me.ZOrder 0
        lngResult = ShowMsg(Me.hwnd, "上一次编辑的职员还未保存，是否继续编辑它？", vbYesNoCancel + vbQuestion, "职员卡片提示信息")
        If lngResult = vbYes Then       '继续编辑上一次的职员
            SendKeys "%{C}"
            Exit Function
        Else
            lngResult = ShowMsg(Me.hwnd, "是否保存上一次编辑的职员？", vbYesNoCancel + vbQuestion, "职员卡片提示信息")
            If lngResult = vbYes Then       '保存上一次编辑的职员
                If Not SaveCard Then      '保存失败
                    lngResult = ShowMsg(Me.hwnd, "上一次编辑的职员保存失败，是否继续编辑它？", vbYesNoCancel + vbQuestion, "职员卡片提示信息")
                    If lngResult = vbYes Then
                        SendKeys "%{C}"
                        Exit Function
                    End If
                End If
            End If
        End If
    End If
    IsContinue = False
End Function