frmarrange.frm

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

    Set frmHelp = Nothing
End Sub

Private Sub txtprocode_KeyUp(KeyCode As Integer, Shift As Integer)
Dim lprocode As Long
    If KeyCode = vbKeyF1 Then
        If vasArrange.DataRowCnt > 0 Then
            lprocode = GetValue(vasArrange, 1, enuDetailCols.procode)
        End If
        frmHelp.lprocode = lprocode
        Load frmHelp
              
        frmHelp.Show vbModal
        
        txtprocode.Text = frmHelp.lprocode
        txtprocode.Tag = frmHelp.lprocode
        txtprodesc.Text = frmHelp.sprodesc
        
        Set frmHelp = Nothing
    ElseIf KeyCode = vbKeyReturn Then
        SendKeys "{tab}"
    End If

End Sub

Private Sub txtprocode_LostFocus()
    If txtprocode.Text <> txtprocode.Tag Then
        txtprocode.Text = ""
        txtprocode.Tag = ""
    End If
End Sub

Private Sub txttruck_DblClick()
Dim strucode As String
Dim sTruName As String
Dim sprocode As Long
    
        If txtprocode.Text = "" Then
            MsgBox "Please input Product Code!", vbOKOnly, "Message"
            Exit Sub
        Else
        
        End If
        
        With frmtruHelp
            Load frmHelp
            .lprocode = txtprocode.Text
            .Show vbModal
            strucode = frmtruHelp.strucode
            sTruName = frmtruHelp.strudesc
        End With
        txttruck.Text = strucode
        txttruck.Tag = strucode
        txttrudesc.Text = sTruName
        
End Sub

Private Sub txttruck_KeyUp(KeyCode As Integer, Shift As Integer)
Dim strucode As String
Dim sTruName As String
Dim sprocode As Long
    
    If KeyCode = vbKeyF1 Then
        If txtprocode.Text = "" Then
            MsgBox "Please input Product Code!", vbOKOnly, "Message"
            Exit Sub
        Else
        
        End If
        
        With frmtruHelp
            Load frmHelp
            .lprocode = txtprocode.Text
            .Show vbModal
            strucode = frmtruHelp.strucode
            sTruName = frmtruHelp.strudesc
        End With
        txttruck.Text = strucode
        txttruck.Tag = strucode
        txttrudesc.Text = sTruName
    ElseIf KeyCode = vbKeyReturn Then
        SendKeys "{tab}"
    End If

End Sub

Private Sub txttruck_LostFocus()
    
    If txttruck.Text <> txttruck.Tag Then
        txttruck.Text = ""
        txttruck.Tag = ""
        txttrudesc.Text = ""
    End If
    
End Sub

Private Sub UserControl11_ButtonClick(ByVal Button As MSComctlLib.Button)
On Error GoTo err
    mkey = LCase(Button.Key)

    Select Case LCase(Button.Key)
        Case "new"
            frmHead.Enabled = True
            frmInfo.Enabled = True
            
            txtprocode.SetFocus
        Case "cancel"
            If vasArrange.MaxRows > 0 Then
                Exit Sub
            End If
            Call iniTxt2
            frmHead.Enabled = False
            frmInfo.Enabled = False
        Case "save"
               If vasArrange.MaxRows = 0 Then
                  Exit Sub
               Else
                  If SaveTrip = True Then
                    vasArrange.MaxRows = 0
                  End If
                End If
        Case "close"
            Unload Me
            Exit Sub
    End Select

    Call SetToolBar(mkey)

    Exit Sub

err:

End Sub

Private Function SaveTrip() As Boolean
On Error GoTo err
Dim i As Long
Dim lOrderLin() As Long
Dim sOrderLin As String
Dim sSQL1 As String, sSQL2 As String, sSQL3 As String, sSQL4 As String, sSQL5 As String
Dim lTripsNo As Long
Dim rsttrip As Recordset
Dim strucode As String, strudesc As String
Dim sdrvcode1 As String, sdrvname1 As String
Dim sdrvcode2 As String, sdrvname2 As String, sguarder As String
Dim lbegdate As Long, lenddate As Long
Dim litecode As Long, smeaunit As String
Dim lTripDate1 As Long

    SaveTrip = False
        
    If txttruck.Text = "" Then
        MsgBox "Please input the correct data!", vbOKOnly, "Message"
        Exit Function
    End If
    
    If txtdriver1.Text = "" Then
        MsgBox "Please input the correct data", vbOKOnly, "Message"
        Exit Function
    End If
    
    If txtguarder.Text = "" Then
        MsgBox "Please input the correct data", vbOKOnly, "Message"
        Exit Function
    End If
        
    If txtdriver1.Text = txtdriver2.Text Then
        MsgBox "Driver can't be one!", vbOKOnly, "Error"
        Exit Function
    End If

    strucode = txttruck.Text
    strudesc = txttrudesc.Text
    sdrvcode1 = txtdriver1.Text
    sdrvname1 = txtdrvdesc1.Text
    sdrvcode2 = txtdriver2.Text
    sdrvname2 = txtdrvdesc2.Text
    sguarder = txtguarder.Text
    
    lbegdate = ChangeDate(DTPicker1.Value)
    lenddate = ChangeDate(DTPicker2.Value)
       
    lTripDate1 = ChangeDate(Date)
    
    lTripsNo = 0
    Set rsttrip = Acs_cnt.Execute("select max(tripsno) as maxtripsno from triphead where tripsno>0")
    With rsttrip
    Do While Not .EOF
        lTripsNo = IIf(IsNull(rsttrip!maxtripsno) = True, 0, rsttrip!maxtripsno)
        .MoveNext
    Loop
    End With
    
    rsttrip.Close
    Set rsttrip = Nothing
    
    lTripsNo = lTripsNo + 1
    
    ReDim Preserve lOrderLin(vasArrange.DataRowCnt)
    
    For i = 1 To vasArrange.DataRowCnt
        
        lOrderLin(i) = GetValue(vasArrange, i, enuDetailCols.Id)
    
    Next i
    
    litecode = GetValue(vasArrange, 1, enuDetailCols.procode)
    smeaunit = GetValue(vasArrange, 1, enuDetailCols.Meaunit)
    
    sOrderLin = "(" & lOrderLin(1)
    For i = 2 To UBound(lOrderLin)
        sOrderLin = sOrderLin & "," & lOrderLin(i)
    Next i
    sOrderLin = sOrderLin & ")"
    
    sSQL1 = "update ttosta set tripsno=" & lTripsNo & " where id in " & sOrderLin & ""
    
    sSQL2 = "insert into triphead(entcode,tripsno,truckno,trudesc,estbegd,estarrd,driver1,drvname1,driver2,drvname2,guarder,itecode,meaunit,tripdate1)" & _
            " values('" & gsEntCode & "'," & lTripsNo & ",'" & strucode & "','" & strudesc & "'," & lbegdate & "," & lenddate & "," & _
            " '" & sdrvcode1 & "','" & sdrvname1 & "','" & sdrvcode2 & "','" & sdrvname2 & "','" & sguarder & "'," & litecode & ",'" & smeaunit & "'," & lTripDate1 & ")"
    
    sSQL3 = "insert into apptrs(entcode,truckno,begdate,enddate,astatus) values('" & gsEntCode & "','" & strucode & "' ,'" & lbegdate & "','" & lenddate & "','T')"
    
    sSQL4 = "insert into appdcd(entcode,drvcode,drvname,begdate,enddate,astatus) values('" & gsEntCode & "','" & sdrvcode1 & "' ,'" & sdrvname1 & "','" & lbegdate & "','" & lenddate & "','T')"

    If sdrvcode2 <> "" Then
        sSQL5 = "insert into appdcd(entcode,drvcode,drvname,begdate,enddate,astatus) values('" & gsEntCode & "','" & sdrvcode2 & "' ,'" & sdrvname2 & "','" & lbegdate & "','" & lenddate & "','T')"
    Else
        sSQL5 = ""
    End If

    Acs_cnt.BeginTrans
    Acs_cnt.Execute (sSQL1)
    Acs_cnt.Execute (sSQL2)
    Acs_cnt.Execute (sSQL3)
    Acs_cnt.Execute (sSQL4)
    If sSQL5 <> "" Then
        Acs_cnt.Execute (sSQL5)
    End If
    Acs_cnt.CommitTrans
    
    Call iniTxt2
    
    SaveTrip = True
    
    Exit Function
err:
    MsgBox err.Description, vbOKOnly, "Message"
End Function

Private Sub SetToolBar(ByVal mkey As String)

        Select Case mkey
        Case "new"
            With UserControl11
                .DisplayButton "New", "New", False, , "New"
                .DisplayButton "Save", "Save", True, , "Save"
                .DisplayButton "Cancel", "Cancel", True, , "Cancel"
                .DisplayButton "Close", "Close", True, , "Close"
            End With
        Case "cancel"
            With UserControl11
                .DisplayButton "New", "New", True, , "New"
                .DisplayButton "Save", "Save", False, , "Save"
                .DisplayButton "Cancel", "Cancel", False, , "Cancel"
                .DisplayButton "Close", "Close", True, , "Close"
            End With
        Case "save"
            With UserControl11
                .DisplayButton "New", "New", False, , "New"
                .DisplayButton "Save", "Save", True, , "Save"
                .DisplayButton "Cancel", "Cancel", True, , "Cancel"
                .DisplayButton "Close", "Close", True, , "Close"
            End With
         Case "close"
            Unload Me
            Exit Sub
        End Select

End Sub

Private Function saveinfo() As Boolean
On Error GoTo err
Dim dquantity As Double, smeaunit As String
Dim strucode As String, strudesc As String
Dim lprocode As Long, sprodesc As String
Dim lcuscode As Long, scusdesc As String
Dim lsalonum As Long, lpicknum As Long, lsalolin As Long
Dim lbegdate As Long, lenddate As Long
Dim sSQL1 As String, sSQL2 As String, sSQL3 As String
Dim sSQL4 As String, sSQL5 As String, sSQL6 As String
Dim sSQL As String
Dim rstTemp As New Recordset
Dim soquantity As Double, doquantity As Double, toquantity As Double
    saveinfo = False
       
        strucode = txttruck.Text
        
        dquantity = txtquantity.Text
        smeaunit = lblmeaunit.Caption
        
        lprocode = txtprocode.Text
        sprodesc = txtprodesc.Text
        lcuscode = txtcuscode.Text
        scusdesc = txtcusdesc.Text
        lsalonum = txtordnum.Text
        lpicknum = txtpicknum.Text
        lsalolin = txtsalolin.Text
        
        sSQL1 = "insert into ttosta(entcode,salonum,picknum,salolin,itecode,cuscode,voldeli,meaunit)" & _
               " values('" & gsEntCode & "'," & lsalonum & "," & lpicknum & "," & lsalolin & "," & lprocode & ", " & lcuscode & "," & dquantity & ",'" & smeaunit & "')"


'        sSQL3 = "update apptru set ActInve=actinve + " & dquantity & " where truckno='" & strucode & "'"
       
        sSQL6 = "update orderd set salotyp ='TO' where salonum=" & lsalonum & " and salolin=" & lsalolin & ""

        Acs_cnt.BeginTrans
        Acs_cnt.Execute (sSQL1)
'        Acs_cnt.Execute (sSQL3)

        Acs_cnt.Execute (sSQL6)
        Acs_cnt.CommitTrans

    
    soquantity = 0
    doquantity = 0
    toquantity = 0
    
    sSQL = "select cuscode,itecode,salotyp,sum(sugoqty) as ordernum from orderd " & _
           " where salotyp in('SO','DO','TO') and itecode=" & lprocode & " and cuscode=" & lcuscode & " group by cuscode,itecode,salotyp"
    Set rstTemp = Acs_cnt.Execute(sSQL)
    With rstTemp
    Do While Not .EOF
        If rstTemp!salotyp = "SO" Then
            soquantity = rstTemp!ordernum
         ElseIf rstTemp!salotyp = "DO" Then
            doquantity = rstTemp!ordernum
        ElseIf rstTemp!salotyp = "TO" Then
            toquantity = rstTemp!ordernum
        End If
        
        .MoveNext
    Loop
    End With

    

    sSQL = "update appcut set orderso=" & soquantity & ",orderdo=" & doquantity & ",orderto=" & toquantity & " where procode=" & lprocode & ""
    Acs_cnt.BeginTrans
    Acs_cnt.Execute (sSQL)
    Acs_cnt.CommitTrans

    
    rstTemp.Close
    Set rstTemp = Nothing
    
    saveinfo = True

    Exit Function

err:
    MsgBox err.Description, vbOKOnly, "Error"

End Function