frmjobcard.frm

金算盘软件代码

    Select Case Index
    Case 0
        If mlngLstID(Index) = 0 Then
            ShowMsg hwnd, "请先选择工程状态再进行修改", vbExclamation, Caption
            Exit Sub
        End If
        Card.EditCard Message.msgJobStatus, mlngLstID(Index)
    Case 1
        If mlngLstID(Index) = 0 Then
            ShowMsg hwnd, "请先选择所属单位再进行修改", vbExclamation, Caption
            Exit Sub
        End If
        Card.EditCard Message.msgCustomer, mlngLstID(Index)
    Case 2
        If mlngLstID(Index) = 0 Then
            ShowMsg hwnd, "请先选择承办职员再进行修改", vbExclamation, Caption
            Exit Sub
        End If
        Card.EditCard Message.msgEmployee, mlngLstID(Index)
    Case 3
        If mlngLstID(Index) = 0 Then
            ShowMsg hwnd, "请先选择工程类型再进行修改", vbExclamation, Caption
            Exit Sub
        End If
        Card.EditCard Message.msgJobType, mlngLstID(Index)
    End Select
    mblnIsChanged = True
    RefreshList lstJob(Index), Index
    If lstJob(Index).Text = "" Then mlngLstID(Index) = lstJob(Index).ID
End Sub

'当第一次进入列表框时，设置它的选项
Private Sub lstJob_GotFocus(Index As Integer)
    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).ID
    mblnIsChanged = True
End Sub

Private Sub lstJob_ItemNotExist(Index As Integer)
    Dim iResponse As Integer, lngID As Long
    Dim strSql As String
    
    On Error Resume Next
    If Trim(lstJob(Index).Text) = "" Then
        lstJob(Index).Text = ""
        Exit Sub
    End If
    mblnIsExist = True
    Select Case Index
        Case 0
            iResponse = frmMsgQuickAdd.MsgAddShow("工程状态不存在", "工程状态列表中没有“" _
               & lstJob(Index).Text & "”！")
            If iResponse = vbOK Then
                lngID = frmJobStatusCard.AddCard(lstJob(0).Text, 1, True)
            ElseIf iResponse = 0 Then
                lngID = GetNewID("JobStatus")
                strSql = "INSERT INTO JobStatus (lngJobStatusID,strJobStatusName) VALUES (" & lngID & ",'" _
                    & lstJob(0).Text & "')"
                gclsBase.BaseDB.Execute strSql
            Else
                lstJob(0).Text = ""
            End If
        Case 1
            If frmMsgAdd.MsgAddShow("单位不存在", "单位列表中没有“" _
               & lstJob(Index).Text & "”！") = vbOK Then
               lngID = frmCustomerCard.AddCard(lstJob(1).Text, 1, True)
            Else
                lstJob(1).Text = ""
            End If
        Case 2
            If frmMsgAdd.MsgAddShow("员工不存在", "员工列表中没有“" _
               & lstJob(Index).Text & "”！") = vbOK Then
               lngID = frmEmployeeCard.AddCard(lstJob(2).Text, 1, True)
            Else
                lstJob(2).Text = ""
            End If
        Case 3
            If frmMsgAdd.MsgAddShow("工程类型不存在", "工程类型列表中没有“" _
               & lstJob(Index).Text & "”！") = vbOK Then
               lngID = frmJobTypeCard.AddCard(lstJob(3).Text, 1, True)
            Else
                lstJob(3).Text = ""
            End If
    End Select
    If lngID <> 0 Then mlngLstID(Index) = lngID
    mblnIsChanged = True
    RefreshList lstJob(Index), Index
    mblnIsExist = False
End Sub

Private Sub lstJob_LostFocus(Index As Integer)
    If Trim(lstJob(Index).Text) = "" Then mlngLstID(Index) = lstJob(Index).ID
    lstJob(Index).MoveFocus
'    BKKEY lstJob(Index).hwnd, vbKeyHome
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
    
    If mblnIsExist Then Exit Sub
    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 MergeAccountDaily(mlngDJobID, mlngJobID, "lngJobID") Then Exit Function
'    If Not DisplaceActivity("ActivityDetail", "lngJobID", mlngDJobID, mlngJobID) Then Exit Function
    If gclsBase.ControlAccount Then
        If Not DisplaceActivity("ARAPInit", "lngJobID", mlngDJobID, mlngJobID) Then Exit Function
    Else
        If Not DisplaceActivity("ARAPInit1", "lngJobID", mlngDJobID, mlngJobID) Then Exit Function
    End If
    If Not MergeBudgetBalance(mlngDJobID, mlngJobID, "lngJobID") Then Exit Function
    If Not DisplaceActivity("ItemActivityDetail", "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(ByRef strName As String) 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, rdOpenStatic)
    If Not recJob.EOF Then
        If recJob!strJobCode = txtJob(0).Text Then
            mlngDJobID = recJob!lngJobID
            strName = recJob!strJobCode & " " & recJob!strJobName
            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(Optional blnByAdd As Boolean = False) As Boolean
    LstIsValid = False
    If Not ItemIsValid("Customer", "lngCustomerID", mlngLstID(1), False, False) Then
        If Not blnByAdd Then
            ShowMsg hwnd, "单位应该是末级，您选择的“" & lstJob(1).Text _
                & "”无效，请重新选择！", vbExclamation, Caption
            lstJob(1).SetFocus
        End If
        Exit Function
    End If
    If Not ItemIsValid("Employee", "lngEmployeeID", mlngLstID(2), False, False) Then
        If Not blnByAdd Then
            ShowMsg hwnd, "职员应该是末级，您选择的“" & lstJob(2).Text _
                & "”无效，请重新选择！", vbExclamation, Caption
            lstJob(2).SetFocus
        End If
        Exit Function
    End If
    If Not ItemIsValid("JobType", "lngJobTypeID", mlngLstID(3)) Then
        If Not blnByAdd Then
            ShowMsg hwnd, "工程类型应该是末级，您选择的“" & lstJob(3).Text _
                & "”无效，请重新选择！", vbExclamation, Caption
            lstJob(3).SetFocus
        End If
        Exit Function
    End If
    LstIsValid = True
End Function

'通过事务处理完成对数据库的操作
Private Function SaveCard(Optional ByVal blnByAdd As Boolean = False) As Boolean
    Dim blnMergeCode As Boolean, intResult As Integer, dblPercent As Double
    Dim recJob As rdoResultset, strSql As String, strDJob As String
    
    On Error GoTo ErrHandle
    gclsBase.BaseWorkSpace.BeginTrans
    SaveCard = False
    If mblnIsExist Then GoTo ErrHandle
    If Not IsNumeric(calJob.Text) Then
        dblPercent = 0
    Else
        dblPercent = calJob.Text
    End If
    If Not blnByAdd Then
        If Trim(txtJob(0).Text) = "" Then  '检查非空项
            ShowMsg hwnd, " 工程编码不能为空！", vbExclamation, Caption
            txtJob(0).SetFocus
            txtJob(0).SelStart = 0
            txtJob(0).SelLength = Len(txtJob(0).Text)
            GoTo ErrHandle
        End If
        If Trim(txtJob(1).Text) = "" Then  '检查非空项
            ShowMsg hwnd, " 工程名称不能为空！", vbExclamation, Caption
            txtJob(1).SetFocus
            txtJob(1).SelStart = 0
            txtJob(1).SelLength = Len(txtJob(1).Text)
            GoTo ErrHandle
        End If
        If Trim(lstJob(3).Text) = "" Then     '检查非空项
            ShowMsg hwnd, " 工程类型不能为空！", vbExclamation, Caption
            lstJob(3).SetFocus
            txtJob(3).SelStart = 0
            txtJob(3).SelLength = Len(txtJob(3).Text)
            GoTo ErrHandle
        End If
        If Trim(lstJob(1).Text) = "" Then   '检查非空项
            ShowMsg hwnd, " 工程所属单位不能为空！", vbExclamation, Caption
            lstJob(1).SetFocus
            lstJob(1).SelStart = 0
            lstJob(1).SelLength = Len(lstJob(1).Text)
            GoTo ErrHandle
        End If
        If dteJob(1).Text <> "" Then
            If dteJob(1).Text < dteJob(0).Text Then
                ShowMsg hwnd, "完工日期不能小于开工日期！", vbExclamation, Caption
                dteJob(1).SetFocus
                dteJob(1).SelStart = 0
                dteJob(1).SelLength = Len(dteJob(1).Text)
                GoTo ErrHandle
            End If
        End If
        GetLstValue
    End If
    If Not LstIsValid(blnByAdd) Then GoTo ErrHandle
    intResult = CheckCode(strDJob)
    If intResult = -2 Then
        If Not blnByAdd Then
            ShowMsg hwnd, "工程名称不能为重复,请重新录入！", vbExclamation, Caption
            txtJob(1).SetFocus
            txtJob(1).SelStart = 0
            txtJob(1).SelLength = Len(txtJob(1).Text)
        End If
        GoTo ErrHandle
    End If
    If intResult = -1 Then
        If mblnIsNew Then
            If Not blnByAdd Then
                ShowMsg hwnd, "工程编码“" & Trim(txtJob(0).Text) _
                    & "”已经存在,请重新录入！", vbExclamation, Caption
                txtJob(0).SetFocus
                txtJob(0).SelStart = 0
                txtJob(0).SelLength = Len(txtJob(0).Text)
            End If
            GoTo ErrHandle
        Else
            If ShowMsg(hwnd, "是否将工程“" & mstrJob & "”与“" _
                & strDJob & "”进行合并?", _
                vbQuestion + vbYesNo, Caption) = vbNo Then
                txtJob(0).SetFocus
                txtJob(0).SelStart = 0
                txtJob(0).SelLength = Len(txtJob(0).Text)
                GoTo ErrHandle
            Else
                blnMergeCode = True
            End If
        End If
    End If
    
    If mblnIsNew Then
        mlngJobID = GetNewID("Job")
        strSql = "INSERT INTO Job(lngJobID,strJobCode,strJobName,blnIsInActive," & _
            "lngJobTypeID,LngCustomerID,LngEmployeeID,LngJobStatusID," & _
            "strBeginDate,strEndDate,dblPercent,strStartDate,strNotes) VALUES(" & mlngJobID & ",'" & _
            Trim(txtJob(0).Text) & "','" & Trim(txtJob(1).Text) & "'," & chkStop.Value & "," & _
            mlngLstID(3) & "," & mlngLstID(1) & "," & mlngLstID(2) & "," & _
            mlngLstID(0) & ",'" & IIf(dteJob(0).Text = "", " ", dteJob(0).Text) & "','" & IIf(dteJob(1).Text = "", " ", dteJob(1).Text) & "'," & _
            dblPercent & ",'" & Format(gclsBase.BaseDate, "YYYY-MM-DD") & "','" & mstrNotes & " ')"
        If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
'        If chkStop.Value <> Checked Then
'            strSql = "SELECT * FROM Job WHERE strJobCode='" & Trim(txtJob(0).Text) & "'"
'            Set recJob = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
'            mlngJobID = recJob!lngJobID
'            recJob.Close
'        End If
    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='" & Trim(txtJob(0).Text) & _
                "',strJobName='" & Trim(txtJob(1).Text) & "',blnIsInActive=" & _
                chkStop.Value & ",lngJobTypeID=" & mlngLstID(3) & _
                ",lngCustomerID=" & mlngLstID(1) & ",lngEmployeeID=" & _
                mlngLstID(2) & ",lngJobStatusID=" & mlngLstID(0) & _
                ",strBeginDate='" & IIf(dteJob(0).Text = "", " ", dteJob(0).Text) & "',strEndDate='" & _
                IIf(dteJob(1).Text = "", " ", 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