frmbus.frm

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

    rstbus.MoveNext
Loop


Call vasbus_Click(lCurCol, lCurRow)

End Sub

Private Sub InitToolBar()
    With UserControl1
        
        .DisplayButton "Save", "Save", False, , "Save"
        .DisplayButton "Cancel", "Cancel", False, , "Cancel"
        .DisplayButton "Modify", "Modify", True, , "Modify"
        .DisplayButton "Upload", "Upload", True, , "Upload"
        .DisplayButton "Close", "Close", True, , "Close"
    End With

End Sub




Private Sub txtbusc_Keydown(KeyCode As Integer, Shift As Integer)
Dim rstbus As Recordset
Dim sSQL As String
Dim sent, sbus As String

If KeyCode = vbKeyReturn Then
        If txtbusc.Text = "" Then
        ElseIf lblstatus.Caption = "search" Then
            sent = txtentc.Text
            sbus = txtbusc.Text
            sSQL = "select * from appbus where entcode = '" & sent & "'and buscode = '" & sbus & "'"
            Set rstbus = Acs_cnt.Execute(sSQL)
            If Not rstbus.EOF Then
                txtbusd.Text = rstbus!Busdesc
            Else
            MsgBox "Can't find the record!", vbExclamation, "Information"
            End If
            rstbus.Close
            Set rstbus = Nothing
            txtentc.SetFocus
            Else
          SendKeys "{tab}"
          End If
    End If
    
End Sub

Private Sub vasbus_Click(ByVal Col As Long, ByVal Row As Long)
Dim status As String
Dim i As Long
    If Row = 0 Then
    Else
        frminput.Enabled = False
        txtentc.Text = gsEntCode
        txtbusc.Text = GetValue(vasbus, Row, 2)
        txtbusd.Text = GetValue(vasbus, Row, 3)
        status = GetValue(vasbus, Row, 4)
        For i = 0 To cblstatus.ListCount - 1
            cblstatus.ListIndex = i
            If cblstatus.Text = status Then
            Exit For
            End If
        Next
    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 "delete"
            MsgBox "The RasCode can't be deleted!", vbExclamation, "Message"
            lblstatus.Caption = "search"
            vasbus.Enabled = False
            frminput.Enabled = True
            txtbusd.Enabled = False
            txtentc.Text = gsEntCode
            txtbusc.Text = ""
            txtbusd.Text = ""
            txtentc.SetFocus
              
      
        Case "modify"
        
        Case "save"
            Call BusSaveInfo
            Call vasshow
            
        Case "close"
            Unload Me
            Exit Sub
            
        Case "upload"
            Call down_sub
        
        Case Else
    
    End Select
    
    Call SetToolBar(mkey)
    
End Sub


Private Sub SetToolBar(ByVal mkey As String)
        Select Case mkey
        Case "cancel"
            With UserControl1
                .DisplayButton "Modify", "Modify", True, , "Modify"
                .DisplayButton "Save", "Save", False, , "Save"
                .DisplayButton "Cancel", "Cancel", False, , "Cancel"
                .DisplayButton "Upload", "Upload", True, , "Upload"
                .DisplayButton "Close", "Close", True, , "Close"
            End With
            vasbus.Enabled = True
            frminput.Enabled = False
            lblstatus.Caption = ""
        
        Case "save"
        With UserControl1
                .DisplayButton "Save", "Save", False, , "Save"
                .DisplayButton "Modify", "Modify", True, , "Modify"
                .DisplayButton "Cancel", "Cancel", False, , "Cancel"
                .DisplayButton "Upload", "Upload", True, , "Upload"
                .DisplayButton "Close", "Close", True, , "Close"
        End With
            vasbus.Enabled = True
            frminput.Enabled = False
        Case "modify"
        With UserControl1
                .DisplayButton "Save", "Save", True, , "Save"
                .DisplayButton "Modify", "Modify", False, , "Modify"
                .DisplayButton "Cancel", "Cancel", True, , "Cancel"
                .DisplayButton "Upload", "Upload", True, , "Upload"
                .DisplayButton "Close", "Close", False, , "Close"
        End With
        vasbus.Enabled = False
        frminput.Enabled = True
        txtentc.Enabled = False
        txtbusc.Enabled = False
        txtbusd.Enabled = False
        cblstatus.Enabled = True
        cblstatus.SetFocus
        Case "upload"
          With UserControl1
               .DisplayButton "Save", "Save", False, , "Save"
               .DisplayButton "Modify", "Modify", False, , "Modify"
               .DisplayButton "Cancel", "Cancel", False, , "Cancel"
               .DisplayButton "Upload", "Upload", False, , "Upload"
               .DisplayButton "Close", "Close", False, , "Close"
          End With
            
            
        End Select

End Sub


Private Sub BusSaveInfo()
Dim Astatus, Buscode As String
Dim sSQL As String
On Error GoTo err
    Astatus = cblstatus.Text
    Buscode = txtbusc.Text
    sSQL = "update appbus set astatus ='" & Astatus & "' where buscode = '" & Buscode & "'"
    Acs_cnt.BeginTrans
    Acs_cnt.Execute (sSQL)
    Acs_cnt.CommitTrans
    lCurRow = vasbus.ActiveRow
    lCurCol = vasbus.ActiveCol
    Exit Sub
err:
    MsgBox err.Description, vbOKOnly, "Error"
End Sub

Private Sub down_sub()
 Dim i As Integer
 PrBar1.Visible = True
 Cmd_ok.Visible = True
 Cmd_no.Visible = True
 vasbus.MaxCols = 2
 vasbus.MaxRows = 0
 SetColHead vasbus, 1, "Bussiness Unit Code", 20
 SetColHead vasbus, 2, "Bussiness Unit Description ", 18
 
 
 ReDim Preserve BusiRc(0) As BusiC
 DBFC ("upload")
 DBF_Rec.Open "select * from business "
 DBF_Rec.MoveFirst
 PrBar1.max = DBF_Rec.RecordCount
  i = 0
  Do
      vasbus.MaxRows = vasbus.MaxRows + 1
      i = i + 1
      PrBar1.Value = i
      BusiRc(UBound(BusiRc)).Buscode = DBF_Rec!mcmcu
      BusiRc(UBound(BusiRc)).Busdesc = "" & DBF_Rec!mcdc '
      SetValue vasbus, i, 1, BusiRc(UBound(BusiRc)).Buscode
      SetValue vasbus, i, 2, BusiRc(UBound(BusiRc)).Busdesc
      ReDim Preserve BusiRc(UBound(BusiRc) + 1) As BusiC
      DBF_Rec.MoveNext
   Loop Until DBF_Rec.EOF
   Cmd_ok.Visible = True
   Cmd_no.Visible = True
   DBFD
   PrBar1.Value = 0
   PrBar1.Visible = False
End Sub

Private Sub cmd_ok_click()
       Dim i As Integer
       Dim acs_rec As Recordset
       Dim sSQL As String
       Cmd_no.Visible = False
       Cmd_ok.Visible = False
       PrBar1.Visible = True
       PrBar1.max = UBound(BusiRc)
       i = 0
       Set acs_rec = Acs_cnt.Execute("select * from appbus")
If acs_rec.EOF = False Then
      For i = 0 To UBound(BusiRc) - 1
          acs_rec.MoveFirst
          PrBar1.Value = i
          Do
               If acs_rec!Buscode = BusiRc(i).Buscode Then
                  sSQL = "delete from appbus where buscode = '" & BusiRc(i).Buscode & "'" & "and entcode = '" & gsEntCode & "'"
                  Acs_cnt.Execute (sSQL)
                  Exit Do
               End If
               acs_rec.MoveNext
          Loop Until acs_rec.EOF
      Next i
      acs_rec.Close
      Set acs_rec = Acs_cnt.Execute("select * from appbus")
      If acs_rec.EOF Then
            For i = 0 To UBound(BusiRc) - 1
                PrBar1.Value = i
                Acs_cnt.Execute " insert into appbus( entcode,buscode,busdesc,astatus)" _
                      & "values ( '" & gsEntCode & "', '" & BusiRc(i).Buscode & "'," & "'" & BusiRc(i).Busdesc & "','Y')"
                i = i + 1
            Next
            acs_rec.Close
      Else
            Acs_cnt.Execute ("update appbus set astatus = 'N'")
            i = 0
            Do
                PrBar1.Value = i
                
                Acs_cnt.Execute " insert into appbus( entcode,buscode,busdesc,astatus)" _
                      & "values ( '" & gsEntCode & "', '" & BusiRc(i).Buscode & "'," & "'" & BusiRc(i).Busdesc & "','Y')"
                i = i + 1
            Loop Until i > UBound(BusiRc) - 1
            acs_rec.Close
      End If
Else
      acs_rec.Close
      Do
        PrBar1.Value = i
        Acs_cnt.Execute " insert into appbus( entcode,buscode,busdesc,astatus)" _
                 & "values ( '" & gsEntCode & "', '" & BusiRc(i).Buscode & "'," & "'" & BusiRc(i).Busdesc & "','Y')"
         i = i + 1
      Loop Until i > UBound(BusiRc) - 1
 End If
           PrBar1.Value = 0
           vasbus.MaxRows = 0
        With UserControl1
             '.DisplayButton "new", "new", False, , "new"
            .DisplayButton "Save", "Save", False, , "Save"
            .DisplayButton "Cancel", "Cancel", False, , "Cancel"
            .DisplayButton "Modify", "Modify", True, , "Modify"
            .DisplayButton "Upload", "Upload", True, , "Upload"
            .DisplayButton "Close", "Close", True, , "Close"
        End With
        vasbus.Enabled = True
        frminput.Enabled = False
      
       PrBar1.Visible = False
       vasbus.MaxCols = 4
       SetColHead vasbus, 1, "Entity Code", 18
       SetColHead vasbus, 2, "Bussiness Unit Code", 20
       SetColHead vasbus, 3, "Bussiness Unit Description ", 18
       SetColHead vasbus, 4, "Active Statutus", 8
       lCurRow = 1
       lCurCol = 1
       Call vasshow
End Sub


Private Sub cmd_no_click()

   'Dim i As Integer
    Cmd_ok.Visible = False
    Cmd_no.Visible = False
    With UserControl1
            
             .DisplayButton "Modify", "Modify", True, , "Modify"
             .DisplayButton "Cancel", "Cancel", False, , "Cancel"
             '.DisplayButton "Redo", "Redo", False, , "Redo"
             .DisplayButton "Upload", "Upload", True, , "Upload"
             .DisplayButton "Close", "Close", True, , "Close"
    End With
    vasbus.Enabled = True
    frminput.Enabled = False
    vasbus.MaxCols = 0
    PrBar1.Visible = False
    vasbus.MaxCols = 4
    SetColHead vasbus, 1, "Entity Code", 18
    SetColHead vasbus, 2, "Bussiness Unit Code", 20
    SetColHead vasbus, 3, "Bussiness Unit Description ", 18
    SetColHead vasbus, 4, "Active Statutus", 8
    lCurRow = 1
    lCurCol = 1
    Call vasshow
End Sub

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