frmdelivery.frm

英文版Access数据库编程

      Width           =   1455
   End
   Begin VB.Label Label7 
      Caption         =   "Remark:"
      Height          =   255
      Left            =   4440
      TabIndex        =   23
      Top             =   2520
      Width           =   1095
   End
   Begin VB.Label Label5 
      Caption         =   "Attention:"
      Height          =   255
      Left            =   4440
      TabIndex        =   22
      Top             =   2160
      Width           =   1095
   End
   Begin VB.Label Label6 
      Caption         =   "PO Number:"
      Height          =   255
      Left            =   4440
      TabIndex        =   21
      Top             =   1800
      Width           =   1095
   End
   Begin VB.Label Label4 
      Caption         =   "Delivered By:"
      ForeColor       =   &H000000FF&
      Height          =   255
      Left            =   4440
      TabIndex        =   20
      Top             =   1200
      Width           =   1095
   End
   Begin VB.Label Label3 
      Caption         =   "Endorsed By:"
      ForeColor       =   &H000000FF&
      Height          =   255
      Left            =   4440
      TabIndex        =   19
      Top             =   840
      Width           =   1095
   End
   Begin VB.Label Label2 
      Caption         =   "Customer ID:"
      ForeColor       =   &H000000FF&
      Height          =   255
      Left            =   120
      TabIndex        =   18
      Top             =   1800
      Width           =   1095
   End
   Begin VB.Label Label1 
      Caption         =   "Date:"
      ForeColor       =   &H000000FF&
      Height          =   255
      Left            =   120
      TabIndex        =   17
      Top             =   840
      Width           =   735
   End
End
Attribute VB_Name = "frmDelivery"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim numItems As Integer
Dim max_Item As Integer
Dim currTotal As Single, addCharge As Single, subTotal As Single

Private Sub cmbCustomer_Click()
If Not cmbCustomer.Text = "" Then
    Dim tempRS As Recordset
    RSOpen tempRS, "SELECT CustomerID FROM Customers WHERE Name='" & cmbCustomer.Text & "'", dbOpenSnapshot
    If Not tempRS.EOF Then
        cmbCustomer.Tag = tempRS("CustomerID")
    End If
    tempRS.Close
    Set tempRS = Nothing
End If
End Sub

Private Sub cmbEmployee_Click(Index As Integer)
If Not cmbEmployee(Index).Text = "" Then
    Dim tempRS As Recordset
    RSOpen tempRS, "SELECT EmployeeID FROM Employees WHERE Name='" & cmbEmployee(Index).Text & "'", dbOpenSnapshot
    If Not tempRS.EOF Then
        cmbEmployee(Index).Tag = tempRS("EmployeeID")
    End If
    tempRS.Close
    Set tempRS = Nothing
End If
End Sub

Private Sub cmdClear_Click()
If numItems > 0 Then
    If MsgBox("Are you sure you want to clear the cart? Every item in the cart will be removed.", vbYesNo + vbQuestion, "Clear cart") = vbYes Then
        lvCart.ListItems.Clear
        subTotal = 0
        numItems = 0
    End If
Else
    InfoMsg "No item in cart.", "Cart empty"
End If
End Sub

Private Sub cmdDone_Click()
If isDateValid(CByte(cmbDate(0).Text), CByte(cmbDate(1).Text), CInt(cmbDate(2).Text)) = False Then
    ValidMsg "Invalid date. Please try again", "Invalid value"
    cmbDate(0).SetFocus
ElseIf isDateValid(CByte(cmbDelDate(0).Text), CByte(cmbDelDate(1).Text), CInt(cmbDelDate(2).Text)) = False Then
    ValidMsg "Invalid delivery date. Please try again.", "Invalid value"
    cmbDelDate(0).SetFocus
ElseIf cmbCustomer.Text = "" Then
    ValidMsg "Please select a customer for this delivery order.", "Missing selection"
    cmbCustomer.SetFocus
ElseIf cmbEmployee(0).Text = "" Then
    ValidMsg "Please select an endorsement officer.", "Missing selection"
    cmbEmployee(0).SetFocus
ElseIf cmbEmployee(1).Text = "" Then
    ValidMsg "Please select a delivery officer.", "Missing selection"
    cmbEmployee(1).SetFocus
ElseIf ((CSng(txtExtra.Text) > 0) And (txtDes.Text = "")) Then
    ValidMsg "Please provide a description for the additional charges.", "Missing values"
    txtDes.SetFocus
ElseIf numItems = 0 Then
    ValidMsg "Please add at least an item into the cart.", "Cart empty"
Else
    Dim tempSQL As String, DONumber As String, DODate As String
    Dim delTime As String, delDate As String
    Dim smallRS As Recordset, i As Integer
    'obtain new delivery order
    'BeginTrans
    'On Error GoTo ErrHandler
    tempSQL = "SELECT * FROM Misc WHERE DataType='DLVR'"
    Set smallRS = MySynonDatabase.OpenRecordset(tempSQL, dbOpenDynaset, dbDenyRead + dbDenyWrite)
    DONumber = Format$(CLng(smallRS("DataValue")), "000000")
    'Update the new delivery order number
    'Assign values to variable
    DODate = cmbDate(0).Text & "/" & cmbDate(1).Text & "/" & cmbDate(2).Text
    delDate = cmbDelDate(0).Text & "/" & cmbDelDate(1).Text & "/" & cmbDelDate(2).Text
    delTime = cmbDelTime(0).Text & ":" & cmbDelTime(1).Text
    'begin insertion of data
    tempSQL = "INSERT INTO Delivery VALUES('" & DONumber & "','" & DODate & "'," & _
    "'" & cmbEmployee(0).Tag & "','" & cmbEmployee(1).Tag & "','" & txtPO.Text & "','" & cmbCustomer.Tag & "'," & _
    "'" & txtREM.Text & "','" & txtAttn.Text & "','" & delDate & "','" & delTime & "'," & _
    "'DELIVERING','" & txtExtra.Text & "','" & txtDes.Text & "')"
    MySynonDatabase.Execute tempSQL
    
    For i = 1 To lvCart.ListItems.Count 'Goes through list of item in cart and add to database
        tempSQL = "INSERT INTO D_Details VALUES ('" & DONumber & "','" & lvCart.ListItems(i).Text & "'," & _
        "'" & lvCart.ListItems(i).SubItems(1) & "','" & lvCart.ListItems(i).SubItems(2) & "','" & lvCart.ListItems(i).SubItems(3) & "'," & _
        "'" & lvCart.ListItems(i).SubItems(4) & "','" & lvCart.ListItems(i).SubItems(5) & "',FALSE)"
        MySynonDatabase.Execute tempSQL
    Next i
    
    smallRS.Edit
    smallRS("DataValue") = CLng(DONumber) + 1
    smallRS.Update
    smallRS.Close
    'Comment the codes above and uncomment the ones below to have table locking
    'Not sure if it is correctly done. If anyone knows how to do it better, please do modify it.
    'and send a copy of this module to me. - Thanks
    'tempSQL = "SELECT * FROM Delivery;"
    'Set smallRS = MySynonDatabase.OpenRecordset(tempSQL, dbOpenDynaset, dbdeny + dbDenyWrite)
    'smallRS.AddNew
    'smallRS("DOnumber") = DONumber
    'smallRS("Date") = DODate
    'smallRS("EmployeeID") = endoEmp(0)
    'smallRS("IssuedBy") = delEmp(0)
    'smallRS("PONumber") = txtPO.Text
    'smallRS("CustomerID") = cmbCustomer.Text
    'smallRS("Remark") = txtREM.Text
    'smallRS("Attn") = txtAttn.Text
    'smallRS("DelDate") = delDate
    'smallRS("DelTime") = delTime
    'smallRS("Status") = "DELIVERING"
    'smallRS("Charges") = txtExtra.Text
    'smallRS("Description") = txtDes.Text
    'smallRS.Update
    
   ' tempSQL = "SELECT * FROM D_Details;"
   ' Set smallRS = MySynonDatabase.OpenRecordset(tempSQL, dbOpenDynaset, dbDenyWrite)
    'For i = 1 To lvCart.ListItems.Count
    '    smallRS.AddNew
    '    smallRS("DOnumber") = DONumber
    '    smallRS("ProductID") = lvCart.ListItems(i).Text
    '    smallRS("Description") = lvCart.ListItems(i).SubItems(1)
    '    smallRS("CustRef") = lvCart.ListItems(i).SubItems(2)
    '    smallRS("Quantity") = lvCart.ListItems(i).SubItems(3)
    '    smallRS("UnitLabel") = lvCart.ListItems(i).SubItems(4)
    '    smallRS("SalePrice") = lvCart.ListItems(i).SubItems(5)
    '    smallRS.Update
    'Next i
    InfoMsg "The delivery order has been created and ready for print.", "Record saved"
    'CommitTrans
    Set smallRS = Nothing
    frmMain.loadRecDeliveries
    Unload Me
End If
ErrHandler:
If Err.Number <> 0 Then
    If Err.Number = 3197 Then
        'Locked record has been updated before hand. Possibly
        InfoMsg "One of the record has been modified. The record has not been saved. Please click 'OK' and try again.", "Record not saved"
        Exit Sub
    Else
        'Rollback
        ErrorNotifier Err.Number, Err.description
    End If
End If
End Sub

Private Sub cmdRemove_Click()
removeItem
End Sub

Private Sub Form_Load()
lblNotes.Caption = "Red labels indicate required information. Items are added from the inventory window simply by right-clicking on them and select 'Add to cart'."
NumDOForm = NumDOForm + 1
Me.Tag = "DO" & NumDOForm
Me.Caption = Me.Caption & " - " & NumDOForm
Dim i As Integer
'Add years
For i = 0 To 5
    cmbDate(2).addItem CStr(Year(Now()) + i)
    cmbDelDate(2).addItem CStr(Year(Now()) + i)
Next i
For i = 0 To 59
    cmbDelTime(1).addItem Format$(i, "00")
Next i

'Populate combo boxes
FillCombo cmbCustomer, "SELECT Name FROM Customers", "Name"
FillCombo cmbEmployee(0), "SELECT Name FROM Employees ORDER BY Name ASC", "Name"
FillCombo cmbEmployee(1), "SELECT Name FROM Employees ORDER BY Name ASC", "Name"

max_Item = CInt(getSettings("cartSize"))
newDelivery
End Sub

Private Sub newDelivery()
'Default date set today
cmbDate(0).Text = Format$(Day(Now()), "00")
cmbDate(1).Text = Format$(Month(Now()), "00")
cmbDate(2).Text = Year(Now())
cmbDelDate(0).Text = cmbDate(0).Text
cmbDelDate(1).Text = cmbDate(1).Text
cmbDelDate(2).Text = cmbDate(2).Text
cmbDelTime(0).Text = Format$(Now(), "hh")
cmbDelTime(1).Text = Right$(Format$(Now(), "hh:mm"), 2)
'Initialise variables
numItems = 0
txtSub.Text = "0.00"
txtExtra.Text = "0.00"
txtGrand.Text = "0.00"

'Clear cart
lvCart.ListItems.Clear
lvCart.ColumnHeaders.Clear

'Set column header
With lvCart.ColumnHeaders
    .add , , "Product ID", 960
    .add , , "Description", 2200
    .add , , "Cust Ref", 1200
    .add , , "Quantity", 900
    .add , , "Unit Label", 900
    .add , , "Unit Price", 900
End With
End Sub

Private Sub removeItem()
Dim i As Integer
With lvCart
If numItems > 0 Then
    If MsgBox("Are you sure you want to remove the selected item(s) from the cart?", vbQuestion + vbYesNo, "Remove item") = vbYes Then
        For i = 1 To .ListItems.Count
            If .ListItems(i).Selected Then
                subTotal = subTotal - (CInt(.ListItems(i).SubItems(3)) * CSng(.ListItems(i).SubItems(5)))
                .ListItems.Remove .SelectedItem.Index
                numItems = numItems - 1
            End If
        Next i
    End If
Else
    InfoMsg "No item in cart.", "Cart empty "
End If
End With
End Sub

Public Sub addItem(ByVal strID As String, ByVal strDes As String, ByVal strRef As String, ByVal strQty As Integer, ByVal strLabel As String, ByVal strPrice As Single)
If numItems > max_Item Then
    InfoMsg "Cart is full.", "Cart full"
Else
    With lvCart.ListItems
        .add , , strID
        .Item(.Count).SubItems(1) = strDes
        .Item(.Count).SubItems(2) = strRef
        .Item(.Count).SubItems(3) = strQty
        .Item(.Count).SubItems(4) = strLabel
        .Item(.Count).SubItems(5) = Format$(strPrice, "#,##0.00")
        subTotal = subTotal + (strPrice * strQty)
        displayTotal
        numItems = numItems + 1
    End With
End If
End Sub

Private Sub displayTotal()
txtSub.Text = Format$(subTotal, "#,##0.00")
txtGrand.Text = Format$(subTotal + CSng(txtExtra.Text), "#,##0.00")
End Sub

Private Sub Form_Unload(Cancel As Integer)
'NumDOForm = NumDOForm - 1
Set frmDelivery = Nothing
End Sub



Private Sub txtExtra_Change()
displayTotal
End Sub

Private Sub txtExtra_GotFocus()
SelText txtExtra
End Sub

Private Sub txtExtra_KeyPress(KeyAscii As Integer)
If KeyAscii <> Asc(".") Then
    OnlyNum KeyAscii
End If
End Sub

Private Sub txtExtra_LostFocus()
txtExtra.Text = Format$(txtExtra.Text, "#,##0.00")
End Sub

Private Sub txtGrand_GotFocus()
SelText txtGrand
End Sub

Private Sub txtGrand_KeyPress(KeyAscii As Integer)
KeyAscii = 0
End Sub

Private Sub txtGrand_LostFocus()
txtGrand.Text = Format$(txtGrand.Text, "#,##0.00")
End Sub

Private Sub txtSub_GotFocus()
SelText txtSub
End Sub

Private Sub txtSub_LostFocus()
txtSub.Text = Format$(txtSub.Text, "#,##0.00")
End Sub