frmjoblistcard.frm

金算盘软件代码

        Select Case Index
            Case 0
                Card.EditCard Message.msgJobStatus, mlngLstID(Index)
            Case 1
                Card.EditCard Message.msgCustomer, mlngLstID(Index)
            Case 2
                Card.EditCard Message.msgEmployee, mlngLstID(Index)
            Case 3
                Card.EditCard Message.msgJobType, mlngLstID(Index)
        End Select
        mblnIsChanged = True
        RefreshList lstJob(Index), Index
    Else
        ShowMsg Me.hwnd, "请先选择一项，再修改！", vbInformation, Me.Caption
    End If
End Sub

'当第一次进入列表框时，设置它的选项
Private Sub lstJob_GotFocus(Index As Integer)
    If mblnIsNew Then
        cmdOK(2).Default = False
    Else
        cmdOK(0).Default = False
    End If
    If lstJob(Index).Referrows <= 1 Then
        RefreshList lstJob(Index), Index
    End If
End Sub

'设置列表框选项
Private Sub RefreshList(lstSetting As ListText, Index As Integer)
    
    Select Case Index
        Case 0
            setlistbox lstSetting, 6, mlngLstID(Index)
        Case 1
            setlistbox lstSetting, 1, mlngLstID(Index)
        Case 2
            setlistbox lstSetting, 5, mlngLstID(Index)
        Case 3
            setlistbox lstSetting, 7, mlngLstID(Index)
    End Select

End Sub

'根据列表框选择结果来调用卡片或存储调用卡片的参数
Private Sub lstjob_Choose(Index As Integer)
    mlngLstID(Index) = lstJob(Index).TextMatrix(lstJob(Index).ReferRow, 1)
    mblnIsChanged = True
End Sub

Private Sub lstJob_ItemNotExist(Index As Integer)
    Dim iResponse As Integer, lngID As Long
    Dim recX As rdoResultset, Strsql As String
    
    Select Case Index
        Case 0
            iResponse = frmMsgQuickAdd.MsgAddShow("工程状态不存在", "工程状态列表中没有“" _
               & lstJob(Index).Text & "”！")
            If iResponse = vbOK Then
                lngID = frmJobStatusCard.AddCard(lstJob(0).Text, 1)
            ElseIf iResponse = 0 Then
                Strsql = "INSERT INTO JobStatus (lngJobStatusID,strJobStatusName) " _
                    & "VALUES (" & GetNewID("JobStatus") & ",'" & lstJob(0).Text & "')"
                gclsBase.BaseDB.Execute Strsql
                Strsql = "SELECT * FROM JobStatus WHERE strJobStatusName='" & lstJob(0).Text & "'"
                Set recX = gclsBase.BaseDB.OpenResultset(Strsql, rdOpenForwardOnly)
                lngID = recX!lngJobStatusID
                recX.Close
            Else
                lstJob(0).Text = ""
            End If
        Case 1
            If frmMsgAdd.MsgAddShow("单位不存在", "单位列表中没有“" _
               & lstJob(Index).Text & "”！") = vbOK Then
               lngID = frmCustomerCard.AddCard(lstJob(1).Text, 1)
            Else
                lstJob(1).Text = ""
            End If
        Case 2
            If frmMsgAdd.MsgAddShow("员工不存在", "员工列表中没有“" _
               & lstJob(Index).Text & "”！") = vbOK Then
               lngID = frmEmployeeCard.AddCard(lstJob(2).Text, 1)
            Else
                lstJob(2).Text = ""
            End If
        Case 3
            If frmMsgAdd.MsgAddShow("工程类型不存在", "工程类型列表中没有“" _
               & lstJob(Index).Text & "”！") = vbOK Then
               lngID = frmJobTypeCard.AddCard(lstJob(3).Text, 1)
            Else
                lstJob(3).Text = ""
            End If
    End Select
    If lngID <> 0 Then mlngLstID(Index) = lngID
    mblnIsChanged = True
    RefreshList lstJob(Index), Index
End Sub

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

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

Private Sub mclsMainControl_EditShowList()
    ShowRelationList
End Sub

Private Sub txtJob_Change(Index As Integer)
    If ContainErrorChar(txtJob(Index).Text, "'`~*@#$%") Then
        BKKEY txtJob(Index).hwnd
    End If
    If Not mblnIsInit Then mblnIsChanged = True
End Sub

Private Sub cmdOK_Click(Index As Integer)
    Dim strNextCode As String
    
    Select Case Index
        Case 0    '确定
            If SaveCard Then Unload Me
        Case 1    '取消
            mblnIsChanged = False
            Unload Me
        Case 2    '下一个
            If SaveCard Then
'                mlngJobID = 0
                mblnIsNew = True
'                mblnIsChanged = True
                strNextCode = GetNextCode(txtJob(0).Text)
                InitCard
                txtJob(0).Text = strNextCode
                txtJob(0).SetFocus
                txtJob(0).SelStart = 0
                txtJob(0).SelLength = Len(txtJob(0).Text)
            End If
        Case 3    '记事簿
            mstrNotes = frmNotePad.EditCard("工程", txtJob(0).Text, txtJob(1).Text, _
                mstrNotes)
    End Select
End Sub

Private Function MergeCode() As Boolean
    
    MergeCode = False
    If Not DisplaceActivity("AccountBalance", "lngJobID", mlngDJobID, mlngJobID) Then Exit Function
    If Not DisplaceActivity("AccountDaily", "lngJobID", mlngDJobID, mlngJobID) Then Exit Function
    If Not DisplaceActivity("ActivityDetail", "lngJobID", mlngDJobID, mlngJobID) Then Exit Function
    If Not DisplaceActivity("PurchaseOrderDetail", "lngJobID", mlngDJobID, mlngJobID) Then Exit Function
    If Not DisplaceActivity("SaleOrderDetail", "lngJobID", mlngDJobID, mlngJobID) Then Exit Function
    MergeCode = True
End Function

'检查录入 1--正确  -1--编码重复  -2--名称重复
Private Function CheckCode() As Integer
    Dim recJob As rdoResultset, Strsql As String
    
    Strsql = "SELECT * FROM Job WHERE (strJobCode='" & txtJob(0).Text _
        & "' Or (strJobName='" & txtJob(1).Text & "' AND lngJobID=" _
        & mlngLstID(0) & ")) AND lngJobID <>" & IIf(mblnIsNew, 0, mlngJobID)
    Set recJob = gclsBase.BaseDB.OpenResultset(Strsql, rdOpenForwardOnly)
    If Not recJob.EOF Then
        If recJob!strJobCode = txtJob(0).Text Then
            mlngDJobID = recJob!lngJobID
            CheckCode = -1
        ElseIf recJob!strJobName = txtJob(1).Text Then
            CheckCode = -2
        End If
    Else
        CheckCode = 1
    End If
    recJob.Close
End Function

Private Sub GetLstValue()
    Dim i As Integer
    
    For i = 0 To 3
        If Trim(lstJob(i).Text) = "" Then mlngLstID(i) = 0
    Next i
End Sub

Private Function LstIsValid() As Boolean
    LstIsValid = False
    If Not ItemIsValid("Customer", "lngCustomerID", mlngLstID(1), False, False) Then
        ShowMsg hwnd, "单位应该是末级，您选择的“" & lstJob(1).Text _
            & "”无效，请重新选择！", vbExclamation, Caption
        lstJob(1).SetFocus
        Exit Function
    End If
    If Not ItemIsValid("Employee", "lngEmployeeID", mlngLstID(2), False, False) Then
        ShowMsg hwnd, "职员应该是末级，您选择的“" & lstJob(2).Text _
            & "”无效，请重新选择！", vbExclamation, Caption
        lstJob(2).SetFocus
        Exit Function
    End If
    If Not ItemIsValid("JobType", "lngJobTypeID", mlngLstID(3)) Then
        ShowMsg hwnd, "工程类型应该是末级，您选择的“" & lstJob(3).Text _
            & "”无效，请重新选择！", vbExclamation, Caption
        lstJob(3).SetFocus
        Exit Function
    End If
    LstIsValid = True
End Function

'通过事务处理完成对数据库的操作
Private Function SaveCard() As Boolean
    Dim blnMergeCode As Boolean, intResult As Integer, dblPercent As Double
    Dim recJob As rdoResultset, Strsql As String
    
    On Error GoTo ErrHandle
    gclsBase.BaseWorkSpace.BeginTrans
    SaveCard = False
    If Not IsNumeric(calJob.Text) Then
        dblPercent = 0
    Else
        dblPercent = calJob.Text
    End If
    If Trim(txtJob(0).Text) = "" Then  '检查非空项
        ShowMsg hwnd, " 工程编码不能为空！", vbExclamation, Caption
        txtJob(0).SetFocus
        SendKeys "{HOME}+{END}"
        GoTo ErrHandle
    End If
    If Trim(txtJob(1).Text) = "" Then  '检查非空项
        ShowMsg hwnd, " 工程名称不能为空！", vbExclamation, Caption
        txtJob(1).SetFocus
        SendKeys "{HOME}+{END}"
        GoTo ErrHandle
    End If
    If Trim(lstJob(3).Text) = "" Then     '检查非空项
        ShowMsg hwnd, " 工程类型不能为空！", vbExclamation, Caption
        lstJob(3).SetFocus
        SendKeys "{HOME}+{END}"
        GoTo ErrHandle
    End If
    If Trim(lstJob(1).Text) = "" Then   '检查非空项
        ShowMsg hwnd, " 工程承办单位不能为空！", vbExclamation, Caption
        lstJob(1).SetFocus
        SendKeys "{HOME}+{END}"
        GoTo ErrHandle
    End If
    If dteJob(1).Text <> "" Then
        If dteJob(1).Text < dteJob(0).Text Then
            ShowMsg hwnd, "完工日期不能小于开工日期！", vbExclamation, Caption
            dteJob(1).SetFocus
            SendKeys "{HOME}+{END}"
            GoTo ErrHandle
        End If
    End If
    GetLstValue
    If Not LstIsValid Then GoTo ErrHandle
    intResult = CheckCode
    If intResult = -2 Then
        ShowMsg hwnd, "工程名称不能为重复,请重新录入！", vbExclamation + MB_TASKMODAL, Caption
        txtJob(1).SetFocus
        SendKeys "{END}+{HOME}"
        GoTo ErrHandle
    End If
    If intResult = -1 Then
        If mblnIsNew Then
            ShowMsg hwnd, "工程编码“" & Trim(txtJob(0).Text) _
                & "”已经存在,请重新录入！", vbExclamation, Caption
            txtJob(0).SetFocus
            SendKeys "{END}+{HOME}"
            GoTo ErrHandle
        Else
            If ShowMsg(hwnd, "是否将工程“" & mstrJob & "”与“" _
                & txtJob(0).Text & " " & txtJob(1).Text & "”进行合并?", _
                vbQuestion + vbYesNo, Caption) = vbNo Then
                txtJob(0).SetFocus
                SendKeys "{END}+{HOME}"
                GoTo ErrHandle
            Else
                blnMergeCode = True
            End If
        End If
    End If
    
    If mblnIsNew Then
        Strsql = "INSERT INTO Job (lngJobID,strJobCode,strJobName,blnIsInActive," & _
            "lngJobTypeID,LngCustomerID,LngEmployeeID,LngJobStatusID," & _
            "strBeginDate,strEndDate,dblPercent,strStartDate,strNotes) VALUES (" & GetNewID("Job") _
            & ",'" & txtJob(0).Text & "','" & txtJob(1).Text & "'," & chkStop.Value _
            & "," & mlngLstID(3) & "," & mlngLstID(1) & "," & mlngLstID(2) & "," & _
            mlngLstID(0) & ",'" & dteJob(0).Text & "','" & dteJob(1).Text & "'," & _
            dblPercent & ",'" & Format(gclsBase.BaseDate, "YYYY-MM-DD") & "','" & mstrNotes & " ')"
        If Not gclsBase.ExecSQL(Strsql) Then GoTo ErrHandle
        Strsql = "SELECT * FROM Job WHERE strJobCode='" & txtJob(0).Text & "'"
        Set recJob = gclsBase.BaseDB.OpenResultset(Strsql, rdOpenForwardOnly)
        mlngJobID = recJob!lngJobID
        recJob.Close
    Else
        If blnMergeCode Then
            If Not MergeCode Then GoTo ErrHandle
            Strsql = "DELETE FROM Job WHERE lngJobID=" & mlngJobID
'            If Not gclsBase.ExecSQL(Strsql) Then GoTo ErrHandle
        Else
            Strsql = "UPDATE Job SET strJobCode='" & txtJob(0).Text & _
                "',strJobName='" & txtJob(1).Text & "',blnIsInActive=" & _
                chkStop.Value & ",lngJobTypeID=" & mlngLstID(3) & _
                ",lngCustomerID=" & mlngLstID(1) & ",lngEmployeeID=" & _
                mlngLstID(2) & ",lngJobStatusID=" & mlngLstID(0) & _
                ",strBeginDate='" & dteJob(0).Text & "',strEndDate='" & _
                dteJob(1).Text & "',dblPercent=" & dblPercent & ",strNotes='" & _
                mstrNotes & " '  WHERE lngJobID=" & mlngJobID
        End If
        If Not gclsBase.ExecSQL(Strsql) Then GoTo ErrHandle
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    SaveCard = True
    gclsSys.SendMessage Me.hwnd, Message.msgJob
    mblnIsChanged = False
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollbackTrans
End Function