frmtrs.frm

用VB6.0编写的关于车辆运输调度的系统

        .DisplayButton "Modify", "Modify", True, , "Modify"
        .DisplayButton "Find", "Find", True, , "Find"
        .DisplayButton "Close", "Close", True, , "Close"
    End With

End Sub

Private Sub initcombobox()
Dim sSQL As String
Dim rsttrs As Recordset
Dim sdesc As String
       
    sSQL = "select * from syssta "
    Set rsttrs = Acs_cnt.Execute(sSQL)
    Do While Not rsttrs.EOF
        sdesc = rsttrs!stacode & "/" & rsttrs!stadesc
        cmbstatus.AddItem (sdesc)
        rsttrs.MoveNext
    Loop
    rsttrs.Close
    Set rsttrs = Nothing
    sSQL = "select truckno from apptru where availab = " & 1
    Set rsttrs = Acs_cnt.Execute(sSQL)
    Do While Not rsttrs.EOF
        cmbcode.AddItem (rsttrs!truckno)
        rsttrs.MoveNext
    Loop

End Sub

Private Sub vasshow()
Dim sSQL As String
Dim rsttrs As Recordset
Dim lrow As Long
    lrow = 0
    vastrs.MaxRows = 0
    sSQL = "select * from apptrs order by truckno"
    Set rsttrs = Acs_cnt.Execute(sSQL)
    Do While Not rsttrs.EOF
        lrow = lrow + 1
        vastrs.MaxRows = vastrs.MaxRows + 1
        SetValue vastrs, lrow, 1, gsEntCode
        SetValue vastrs, lrow, 2, "" & rsttrs!truckno
        SetValue vastrs, lrow, 3, "" & rsttrs!Astatus
        SetValue vastrs, lrow, 4, "" & rsttrs!begdate
        SetValue vastrs, lrow, 5, "" & rsttrs!enddate
        SetValue vastrs, lrow, 6, "" & rsttrs!feecost
        SetValue vastrs, lrow, 7, "" & rsttrs!ID
        rsttrs.MoveNext
    Loop
    rsttrs.Close
    Set rsttrs = Nothing
    Call vastrs_Click(lCurCol, lCurRow)
    
End Sub

Private Sub txtcost_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Then
        SendKeys "{tab}"
    End If
End Sub

Private Sub txtcost_LostFocus()
    If IsNumeric(txtcost.Text) Then
    Else
        MsgBox "The input must be numeric!", vbOKOnly, "Information"
        txtcost.SetFocus
    End If
End Sub

Private Sub vastrs_Click(ByVal Col As Long, ByVal Row As Long)
Dim sbeg, send As String
Dim i As Long
Dim code, status As String
Dim sSQL As String
Dim rsttrs As Recordset
    If Row <> 0 Then
        txtentc.Text = GetValue(vastrs, Row, 1)
        code = GetValue(vastrs, Row, 2)
        status = GetValue(vastrs, Row, 3)
        For i = 0 To cmbcode.ListCount - 1
            cmbcode.ListIndex = i
            If code = cmbcode.Text Then
            Exit For
            End If
        Next
        sSQL = "select * from syssta"
        Set rsttrs = Acs_cnt.Execute(sSQL)
        Do While Not rsttrs.EOF
            If status = rsttrs!stacode Then
                status = status & "/" & rsttrs!stadesc
                Exit Do
            End If
            rsttrs.MoveNext
        Loop
        rsttrs.Close
        Set rsttrs = Nothing
        For i = 0 To cmbstatus.ListCount - 1
            cmbstatus.ListIndex = i
            If status = cmbstatus.Text Then
            Exit For
            End If
        Next
        
        sbeg = GetValue(vastrs, Row, 4)
        send = GetValue(vastrs, Row, 5)
        If sbeg <> "" And sbeg <> "0" Then
             DTPicker1.Value = Mid(sbeg, 1, 4) & "-" & Mid(sbeg, 5, 2) & "-" & Mid(sbeg, 7, 2)
        Else
           DTPicker1.Value = 0
        End If
        If send <> "" And send <> "0" Then
            DTPicker2.Value = Mid(send, 1, 4) & "-" & Mid(send, 5, 2) & "-" & Mid(send, 7, 2)
        Else
            DTPicker1.Value = 0
        End If
        txtcost.Text = GetValue(vastrs, Row, 6)
    End If
End Sub

Private Sub cmbstatus_KeyUp(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyReturn Then
            If cmbstatus.Text = "" Then
            Else
              SendKeys "{tab}"
              End If
        End If
End Sub

Private Sub cmbcode_KeyDown(KeyCode As Integer, Shift As Integer)

If KeyCode = vbKeyReturn Then
    SendKeys "{tab}"
End If

End Sub

Private Sub UserControl1_ButtonClick(ByVal Button As MSComctlLib.Button)
    On Error Resume Next
    mkey = LCase(Button.Key)

    Select Case LCase(Button.Key)

        Case "new"
            lblstatus.Caption = mkey
            Call IniStaDetail
        Case "save"
            If lblstatus.Caption = "new" Then
                If savetrsinfo = False Then
                Exit Sub
                End If
                Call vasshow
            ElseIf lblstatus.Caption = "modify" Then
                If trsmodify = False Then
                Exit Sub
                Call vasshow
                End If
            End If
        Case "find"
            Call IniStaDetail
            lblstatus.Caption = "search"
        Case "cancel"
            Call vastrs_Click(vastrs.ActiveCol, vastrs.ActiveRow)
        Case "modify"
            lblstatus.Caption = mkey

        Case "close"
            Unload Me
            Exit Sub

    End Select
    
    Call SetToolBar(mkey)
    
End Sub

Private Sub SetToolBar(ByVal mkey As String)
        Select Case mkey
        Case "new"
            With UserControl1
                .DisplayButton "New", "New", False, , "New"
                .DisplayButton "Find", "Find", False, , "Find"
                .DisplayButton "Modify", "Modify", False, , "Modify"
                .DisplayButton "Save", "Save", True, , "Save"
                .DisplayButton "Cancel", "Cancel", True, , "Cancel"
                .DisplayButton "Close", "Close", False, , "Close"
            End With
            vastrs.Enabled = False
            frminput.Enabled = True
            txtentc.Enabled = False
            cmbcode.Enabled = True
            cmbstatus.Enabled = True
            cmbcode.SetFocus
        Case "modify"
            With UserControl1
                .DisplayButton "New", "New", False, , "New"
                .DisplayButton "Find", "Find", False, , "Find"
                .DisplayButton "Modify", "Modify", False, , "Modify"
                .DisplayButton "Save", "Save", True, , "Save"
                .DisplayButton "Cancel", "Cancel", True, , "Cancel"
                .DisplayButton "Close", "Close", False, , "Close"
            End With
            vastrs.Enabled = False
            frminput.Enabled = True
            txtentc.Enabled = False
            cmbcode.Enabled = False
            cmbstatus.Enabled = True
            cmbstatus.SetFocus
            
        Case "cancel"
            With UserControl1
                .DisplayButton "New", "New", True, , "New"
                .DisplayButton "Find", "Find", True, , "Find"
                .DisplayButton "Modify", "Modify", True, , "Modify"
                .DisplayButton "Save", "Save", False, , "Save"
                .DisplayButton "Cancel", "Cancel", False, , "Cancel"
                .DisplayButton "Close", "Close", True, , "Close"
            End With
            vastrs.Enabled = True
            frminput.Enabled = False
            lblstatus.Caption = ""
            cmbstatus.Enabled = True
            DTPicker1.Enabled = True
            DTPicker2.Enabled = True
        Case "find"
            With UserControl1
                .DisplayButton "New", "New", False, , "New"
                .DisplayButton "Find", "Find", False, , "Find"
                .DisplayButton "Save", "Save", False, , "Save"
                .DisplayButton "Modify", "Modify", True, , "Modify"
                .DisplayButton "Cancel", "Cancel", True, , "Cancel"
                .DisplayButton "Close", "Close", True, , "Close"
            End With
            vastrs.Enabled = False
            frminput.Enabled = True
            cmbstatus.Enabled = True
            txtentc.Text = gsEntCode
            cmbcode.Enabled = True
            cmbcode.Text = ""
            cmbstatus.Text = ""
            cmbstatus.Enabled = False
            DTPicker1.Enabled = False
            DTPicker2.Enabled = False
            cmbcode.SetFocus
        Case "save"
            With UserControl1
                .DisplayButton "New", "New", True, , "New"
                .DisplayButton "Find", "Find", True, , "Find"
                .DisplayButton "Save", "Save", False, , "Save"
                .DisplayButton "Modify", "Modify", True, , "Modify"
                .DisplayButton "Cancel", "Cancel", False, , "Cancel"
                .DisplayButton "Close", "Close", True, , "Close"
            End With
            vastrs.Enabled = True
            frminput.Enabled = False
            cmbstatus.Enabled = True
            DTPicker1.Enabled = True
            DTPicker2.Enabled = True
            Call vasshow
        End Select

End Sub

Private Sub IniStaDetail()
txtentc.Text = gsEntCode
cmbcode.ListIndex = 0
cmbstatus.ListIndex = 0
DTPicker1.Value = Now
DTPicker2.Value = Now
txtcost.Text = ""

End Sub

Private Function savetrsinfo() As Boolean
On Error GoTo err
Dim rsttrs As Recordset
Dim sSQL As String
Dim sent, stru, Astatus As String
Dim enddate, begdate As Long
Dim flag As Boolean
Dim cost As Double

    savetrsinfo = False
    sent = gsEntCode
    stru = cmbcode.Text
    Astatus = cmbstatus.Text
    Astatus = LTrim(Astatus)
    Astatus = Left(Astatus, 3)
    begdate = ChangeDate(DTPicker1.Value)
    enddate = ChangeDate(DTPicker2.Value)
    
    If txtcost.Text = "" Then
        cost = 0
    Else
        cost = CDbl(txtcost.Text)
    End If
    flag = txtentc.Text <> "" And cmbcode.Text <> "" And cmbstatus.Text <> ""
        
    If flag Then
'        sSQL = "select * from apptrs where truckno='" & stru & "'"
'        Set rsttrs = Acs_cnt.Execute(sSQL)
'        With rsttrs
'        If Not .EOF Then
'            MsgBox "This Truck Code is exist,please change the code!", vbInformation, "Error"
'            Exit Function
'        End If
'        End With
        
        sSQL = "insert into apptrs (entcode, truckno, astatus,begdate,enddate,feecost)" & _
        "values('" & sent & "','" & stru & "', '" & Astatus & "'," & begdate & "," & enddate & "," & cost & ")"
        Acs_cnt.BeginTrans
        Acs_cnt.Execute (sSQL)
        Acs_cnt.CommitTrans
'        rsttrs.Close
'        Set rsttrs = Nothing
'        vastrs.MaxRows = vastrs.MaxRows + 1
    Else
    MsgBox "One or Some items are not input!", vbExclamation, "Error"
    
    Exit Function
    End If
    savetrsinfo = True
    
    Exit Function
err:
    MsgBox err.Description, vbOKOnly, "Message"
End Function

Private Function trsmodify() As Boolean
Dim sSQL As String
Dim stru, Astatus As String
Dim begdate, enddate As Long
Dim sbeg, send As String
Dim cost As Double
Dim code As Long
Dim Row As Long

    trsmodify = False
    Row = vastrs.ActiveRow
    code = GetValue(vastrs, Row, 7)
    stru = cmbcode.Text
    Astatus = cmbstatus.Text
    Astatus = LTrim(Astatus)
    Astatus = Left(Astatus, 3)
    begdate = ChangeDate(DTPicker1.Value)
    enddate = ChangeDate(DTPicker2.Value)
    If txtcost.Text = "" Then
        cost = 0
    Else
        cost = CDbl(txtcost.Text)
    End If
    sSQL = "update apptrs set astatus ='" & Astatus & "',begdate = " & begdate & ", enddate = " & enddate & ", feecost = " & cost & " where id = " & code
    Acs_cnt.BeginTrans
    Acs_cnt.Execute (sSQL)
    Acs_cnt.CommitTrans
    trsmodify = True

End Function

Private Sub vastrs_KeyUp(KeyCode As Integer, Shift As Integer)
Dim lrow As Long
Dim lcol As Long
    lrow = vastrs.ActiveRow
    lcol = vastrs.ActiveCol
    If KeyCode = vbKeyUp Or KeyCode = vbKeyDown Then
        Call vastrs_Click(lcol, lrow)
    End If
End Sub