frmdcd.frm

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

    Loop
    
    rstdcd.Close
    Set rstdcd = Nothing
    
End Sub

Private Sub InitToolBar()
    With UserControl1
        .DisplayButton "New", "New", True, , "New"
        .DisplayButton "Save", "Save", False, , "Save"
        .DisplayButton "Cancel", "Cancel", False, , "Cancel"
        '.DisplayButton "Redo", "Redo", False, , "Redo"
        .DisplayButton "Modify", "Modify", True, , "Modify"
        .DisplayButton "Find", "Find", True, , "Find"
        '.DisplayButton "Print", "Print", True, , "Print"
        .DisplayButton "Close", "Close", True, , "Close"
    End With

End Sub

Private Sub IniSpread()
   
    With vasdcd
        .MaxRows = 0
        .MaxCols = enuDetailCols.MaxCols
        .ShadowColor = genuBACKCOLOR.CST_Grid_LostFocus
        .Row = -1: .Col = -1
        .BackColor = genuBACKCOLOR.CST_Grid_LostFocus
        .GridColor = vbBlack
    End With
    
    Call IniSpreadHead
    Call lockspread(vasdcd, True)
    
    vasdcd.ColsFrozen = 1

End Sub

Private Sub IniSpreadHead()

vasdcd.MaxCols = 6
SetColHead vasdcd, enuDetailCols.Entcode, "Entity Code", 10
SetColHead vasdcd, enuDetailCols.drvcode, "Driver Code", 10
SetColHead vasdcd, enuDetailCols.Astatus, "Status", 10
SetColHead vasdcd, enuDetailCols.begdate, "Begin Date", 10
SetColHead vasdcd, enuDetailCols.enddate, "End Date", 10
SetColHead vasdcd, enuDetailCols.ID, "id", 10, True

End Sub

Private Sub vasshow()
Dim rstdcd As Recordset
Dim sSQL As String
Dim lrow As Integer
    
    sSQL = "select * from appdcd order by drvcode"
    Set rstdcd = Acs_cnt.Execute(sSQL)
    lrow = 0
    vasdcd.MaxRows = 0
    With rstdcd
    Do While Not .EOF
        vasdcd.MaxRows = vasdcd.MaxRows + 1
        lrow = lrow + 1
        SetValue vasdcd, lrow, 1, gsEntCode
        SetValue vasdcd, lrow, 2, rstdcd!drvcode
        SetValue vasdcd, lrow, 3, rstdcd!Astatus
        SetValue vasdcd, lrow, 4, rstdcd!begdate
        SetValue vasdcd, lrow, 5, rstdcd!enddate
        SetValue vasdcd, lrow, 6, rstdcd!ID
               
        .MoveNext
    Loop
    End With
    
    rstdcd.Close
    Set rstdcd = Nothing
    Call vasdcd_Click(lCurCol, lCurRow)
    
End Sub


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

Private Sub vasdcd_Click(ByVal Col As Long, ByVal Row As Long)
Dim sbegdate, senddate As String
Dim i As Long
Dim code As String
Dim status As String
Dim sSQL As String
Dim rstdcd As Recordset
Dim statusc As String
Dim name As String
On Error GoTo err

    If Row = 0 Then
    Else
        txtentc.Text = gsEntCode
        code = GetValue(vasdcd, Row, 2)
        statusc = GetValue(vasdcd, Row, 3)
        sSQL = "select drvname from appdrv where drvcode ='" & code & "'"
        Set rstdcd = Acs_cnt.Execute(sSQL)
        If Not rstdcd.EOF Then
            name = rstdcd!drvname
        For i = 0 To cmbcode.ListCount - 1
            cmbcode.ListIndex = i
            If cmbcode.Text = code & "/" & name Then
            Exit For
            End If
        Next
        End If
        rstdcd.Close
        Set rstdcd = Nothing
        
        sSQL = "select * from sysrea"
        Set rstdcd = Acs_cnt.Execute(sSQL)
        Do While Not rstdcd.EOF
            If statusc = rstdcd!reacode Then
            status = rstdcd!readesc
            Exit Do
            End If
        rstdcd.MoveNext
        Loop
        rstdcd.Close
        Set rstdcd = Nothing
        For i = 0 To cmbstatus.ListCount - 1
            cmbstatus.ListIndex = i
            If cmbstatus.Text = statusc & "/" & status Then
            Exit For
            End If
        Next
        
        sbegdate = GetValue(vasdcd, Row, 4)
        senddate = GetValue(vasdcd, Row, 5)
        If sbegdate <> "0" And sbegdate <> "" Then
            sbegdate = Mid(sbegdate, 1, 4) & "-" & Mid(sbegdate, 5, 2) & "-" & Mid(sbegdate, 7, 2)
            DTPicker1.Value = sbegdate
        Else
        Exit Sub
        End If
        If senddate <> "0" And senddate <> "" Then
            senddate = Mid(senddate, 1, 4) & "-" & Mid(senddate, 5, 2) & "-" & Mid(senddate, 7, 2)
            DTPicker2.Value = senddate
        Else
        Exit Sub
        End If
    End If
    Exit Sub
err:
    MsgBox err.Description, vbOKOnly, "Error"
    
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 SavedrvInfo = False Then
                Exit Sub
                End If
                Call vasshow
            ElseIf lblstatus.Caption = "modify" Then
                If drvmodify = False Then
                Exit Sub
                Call vasshow
                End If
            End If
        Case "find"
            lblstatus.Caption = "search"
        Case "cancel"
            Call vasdcd_Click(vasdcd.ActiveCol, vasdcd.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
            vasdcd.Enabled = False
            frminput.Enabled = True
            txtentc.Enabled = False
            cmbcode.Enabled = True
            cmbstatus.Enabled = True
            DTPicker1.Enabled = True
            DTPicker2.Enabled = True
            cmbcode.SetFocus
        Case "modify"
            With UserControl1
                .DisplayButton "New", "New", False, , "New"
                .DisplayButton "Find", "Find", False, , "Find"
                '.DisplayButton "Print", "Print", False, , "Print"
                .DisplayButton "Modify", "Modify", False, , "Modify"
                .DisplayButton "Save", "Save", True, , "Save"
                .DisplayButton "Cancel", "Cancel", True, , "Cancel"
                '.DisplayButton "Redo", "Redo", True, , "Redo"
                .DisplayButton "Close", "Close", False, , "Close"
            End With
            vasdcd.Enabled = False
            frminput.Enabled = True
            txtentc.Enabled = False
            cmbcode.Enabled = False
            cmbstatus.Enabled = True
            DTPicker1.Enabled = True
            DTPicker2.Enabled = True
            cmbstatus.SetFocus
            
        Case "cancel"
            With UserControl1
                .DisplayButton "New", "New", True, , "New"
                .DisplayButton "Find", "Find", True, , "Find"
                '.DisplayButton "Print", "Print", True, , "Print"
                .DisplayButton "Modify", "Modify", True, , "Modify"
                .DisplayButton "Save", "Save", False, , "Save"
                .DisplayButton "Cancel", "Cancel", False, , "Cancel"
                '.DisplayButton "Redo", "Redo", False, , "Redo"
                .DisplayButton "Close", "Close", True, , "Close"
            End With
            vasdcd.Enabled = True
            frminput.Enabled = False
            cmbstatus.Enabled = True
            DTPicker1.Enabled = True
            DTPicker2.Enabled = True
            lblstatus.Caption = ""
        Case "find"
            With UserControl1
                .DisplayButton "New", "New", False, , "New"
                .DisplayButton "Find", "Find", False, , "Find"
                '.DisplayButton "Print", "Print", True, , "Print"
                .DisplayButton "Save", "Save", False, , "Save"
                .DisplayButton "Modify", "Modify", True, , "Modify"
                .DisplayButton "Cancel", "Cancel", True, , "Cancel"
                '.DisplayButton "Redo", "Redo", True, , "Redo"
                .DisplayButton "Close", "Close", True, , "Close"
            End With
            vasdcd.Enabled = False
            frminput.Enabled = True
            cmbstatus.Enabled = True
            txtentc.Text = gsEntCode
            cmbcode.Enabled = True
            cmbstatus.Enabled = False
'            DTPicker1.Enabled = False
'            DTPicker2.Enabled = False
            cmbcode.Text = ""
            cmbstatus.Text = ""
            cmbcode.SetFocus
        Case "save"
            With UserControl1
                .DisplayButton "New", "New", True, , "New"
                .DisplayButton "Find", "Find", True, , "Find"
                '.DisplayButton "Print", "Print", True, , "Print"
                .DisplayButton "Save", "Save", False, , "Save"
                .DisplayButton "Modify", "Modify", True, , "Modify"
                .DisplayButton "Cancel", "Cancel", False, , "Cancel"
                '.DisplayButton "Redo", "Redo", False, , "Redo"
                .DisplayButton "Close", "Close", True, , "Close"
            End With
            vasdcd.Enabled = True
            frminput.Enabled = False
            Call vasshow
        
        End Select

End Sub


Private Sub IniStaDetail()
txtentc.Text = gsEntCode
If cmbcode.ListCount > 0 Then
    cmbcode.ListIndex = 0
End If
If cmbstatus.ListCount > 0 Then
    cmbstatus.ListIndex = 0
End If
DTPicker1.Value = Now
DTPicker2.Value = Now

End Sub


Private Function SavedrvInfo() As Boolean
Dim rstdcd As Recordset
Dim sSQL As String
Dim sent, sdrv, Astatus As String
Dim enddate, begdate As Long
Dim flag As Boolean

    SavedrvInfo = False
    sent = gsEntCode
    sdrv = getstr(cmbcode.Text, "/")
    Astatus = cmbstatus.Text
    Astatus = LTrim(Astatus)
    Astatus = Left(Astatus, 3)
    begdate = ChangeDate(DTPicker1.Value)
    enddate = ChangeDate(DTPicker2.Value)
    
    flag = txtentc.Text <> "" And cmbcode.Text <> "" And cmbstatus.Text <> ""
    
    If flag Then
'        sSQL = "select * from appdcd where drvcode='" & sdrv & "'"
'        Set rstdcd = Acs_cnt.Execute(sSQL)
'        With rstdcd
'        If Not .EOF Then
'            MsgBox "This DrvCode is exist,please change the drvcode!", vbInformation, "Error"
'            Exit Function
'        End If
'        End With
        
        sSQL = "insert into appdcd (entcode, drvcode, astatus,begdate,enddate)" & _
        "values('" & sent & "','" & sdrv & "', '" & Astatus & "'," & begdate & "," & enddate & ")"
        Acs_cnt.BeginTrans
        Acs_cnt.Execute (sSQL)
        Acs_cnt.CommitTrans
'        rstdcd.Close
''        Set rstdcd = Nothing
        vasdcd.MaxRows = vasdcd.MaxRows + 1
    Else
    MsgBox "One or Some items are not input!", vbExclamation, "Error"
    
    Exit Function
    End If
    SavedrvInfo = True
End Function

Private Function drvmodify() As Boolean
Dim sSQL As String
Dim sdrv, Astatus As String
Dim begdate, enddate As Long
Dim code As Long

    drvmodify = False
    sdrv = getstr(cmbcode.Text, "/")
    Astatus = cmbstatus.Text
    Astatus = LTrim(Astatus)
    Astatus = Left(Astatus, 3)
    begdate = ChangeDate(DTPicker1.Value)
    enddate = ChangeDate(DTPicker2.Value)
    code = GetValue(vasdcd, vasdcd.ActiveRow, 6)
    
    sSQL = "update appdcd set astatus ='" & Astatus & "',begdate = " & begdate & "," & "enddate = " & enddate & " where id = " & code
    Acs_cnt.BeginTrans
    Acs_cnt.Execute (sSQL)
    Acs_cnt.CommitTrans
    drvmodify = True

End Function

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


Private Function getstr(ByVal str1 As String, ByVal str2 As String) As String
Dim i As Integer
    If str1 <> "" Then
        i = InStr(1, str1, str2, vbTextCompare)
        If i >= 2 Then
            getstr = Left(str1, i - 1)
        Else
            getstr = str1
        End If
    Else
        getstr = 0
    End If
End Function