frmpurchase.frm

英文版Access数据库编程

   Begin VB.Label lblNotes 
      BackStyle       =   0  'Transparent
      Caption         =   "lblNotes"
      ForeColor       =   &H00FFFFFF&
      Height          =   615
      Left            =   840
      TabIndex        =   14
      Top             =   120
      Width           =   5895
   End
   Begin VB.Shape Shape1 
      BackColor       =   &H00FF8080&
      BackStyle       =   1  'Opaque
      BorderStyle     =   0  'Transparent
      Height          =   855
      Left            =   0
      Top             =   0
      Width           =   8000
   End
End
Attribute VB_Name = "frmPurchase"
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 purchaseSum As Single

Private Sub cash_Click()
Frame2.Enabled = False
supplier.ListIndex = -1
ref.Text = ""
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
        purchaseSum = 0
        numItems = 0
    End If
Else
    InfoMsg "No item in cart.", "Cart empty"
End If
End Sub

Private Sub cmdDone_Click()
If (credit.Value = True) And supplier.Text = "" Then
    ValidMsg "Please select a supplier.", "Missing supplier"
    supplier.SetFocus
ElseIf numItems = 0 Then
    ValidMsg "Please ensure at least 1 item is in the cart.", "No item in cart"
Else
    Dim poRS As Recordset, tmpRS As Recordset
    Dim tmpSQL As String
    Dim newPOID As Long, i As Integer
    On Error GoTo ErrHandler
    BeginTrans
    tmpSQL = "SELECT DataValue FROM Misc WHERE DataType='PO';"
    Set tmpRS = MySynonDatabase.OpenRecordset(tmpSQL, dbOpenDynaset, dbDenyRead + dbDenyWrite)
    newPOID = Format$(tmpRS("DataValue"), "000000")
    'Create new purchase order record
    tmpSQL = "SELECT * FROM Purchase;"
    Set poRS = MySynonDatabase.OpenRecordset(tmpSQL, dbOpenDynaset, dbDenyRead + dbDenyWrite)
    poRS.AddNew
    poRS("poNumber") = newPOID
    If credit.Value = True Then
        poRS("SupplierID") = supplier.Tag
        poRS("isCash") = False
    Else
        poRS("isCash") = True
    End If
    poRS("Date") = Format$(datepk.Day, "00") & "/" & Format$(datepk.Month, "00") & "/" & Format$(datepk.Year, "0000")
    poRS("EmployeeID") = employee.Tag
    poRS("Notes") = notes.Text
    poRS("Ref") = ref.Text
    poRS.Update
    'Update details table
    tmpSQL = "SELECT * FROM P_Details;"
    Set poRS = MySynonDatabase.OpenRecordset(tmpSQL, dbOpenDynaset, dbAppendOnly)
    With lvCart
        For i = 1 To numItems
            poRS.AddNew
            poRS("poNumber") = CStr(newPOID)
            poRS("ProductID") = .ListItems(i).Text
            poRS("CustRef") = .ListItems(i).SubItems(2)
            poRS("Quantity") = CInt(.ListItems(i).SubItems(3))
            poRS("UnitLabel") = .ListItems(i).SubItems(4)
            poRS("UnitPrice") = CSng(.ListItems(i).SubItems(5))
            poRS.Update
        Next i
    End With
    'Update the next key
    tmpRS.Edit
    tmpRS("DataValue") = newPOID + 1
    tmpRS.Update
    CommitTrans
    tmpRS.Close
    poRS.Close
    Set tmpRS = Nothing
    Set poRS = Nothing
    
    InfoMsg "PO Number: " & newPOID & vbCrLf & "The purchase order has been successfully saved and ready for printing.", "Record saved"
    Unload Me
End If
ErrHandler:
If Err.Number <> 0 Then
    Rollback
    ErrorNotifier Err.Number, Err.description
End If
End Sub

Private Sub cmdRemove_Click()
removeItem
End Sub

Private Sub credit_Click()
Frame2.Enabled = True
End Sub

Private Sub employee_Click()
If employee.Text <> "" Then
    employee.Tag = getEmpID(employee.Text)
End If
End Sub

Private Sub Form_Load()
'Insert notes here
lblNotes.Caption = "Red labels indicate required information. " & vbCrLf & "Items are added from the inventory window simply by right-clicking on them and selecting the corresponding purchase order."
'Set the properties of list view
With lvCart
    .View = lvwReport
    .ColumnHeaders.Clear
    .ColumnHeaders.add , , "Product ID", 980
    .ColumnHeaders.add , , "Description", 2000
    .ColumnHeaders.add , , "Supp Ref"
    .ColumnHeaders.add , , "Quantity"
    .ColumnHeaders.add , , "Unit Label"
    .ColumnHeaders.add , , "Unit Price"
End With
FillCombo employee, "SELECT Name FROM Employees;", "Name"
FillCombo supplier, "SELECT Name FROM Suppliers;", "Name"
'Initialise variables
NumPOForm = NumPOForm + 1
Me.Caption = Me.Caption & " - " & NumPOForm
Me.Tag = "PO" & NumPOForm
max_Item = CInt(getSettings("cartSize"))
newPO
End Sub

Private Sub Form_Resize()
Shape1.width = Me.width
lblNotes.width = Me.ScaleWidth - (lblNotes.Left)
End Sub

Private Sub Form_Unload(Cancel As Integer)
'NumPOForm = NumPOForm - 1
Set frmPurchase = Nothing
End Sub

Private Sub newPO()
'Reset the date
datepk.Value = Now()
cash_Click
'Initialise values
ref.Text = ""
total.Text = "0.00"
numItems = 0
purchaseSum = 0
lvCart.ListItems.Clear
notes.Text = ""

supplier.ListIndex = -1
employee.ListIndex = -1
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 numItems
            If .ListItems(i).Selected Then
                adjustSum ((CSng(.ListItems(i).SubItems(3)) * CSng(.ListItems(i).SubItems(5))) * -1)
                .ListItems.Remove .SelectedItem.Index
                numItems = numItems - 1
                displayTotal
            End If
        Next i
    End If
Else
    InfoMsg "No item in cart.", "Cart empty "
End If
End With
End Sub
Private Function getEmpID(ByVal strName As String) As String
Dim tmpRS As Recordset
RSOpen tmpRS, "SELECT EmployeeID FROM Employees WHERE Name='" & strName & "';", dbOpenSnapshot
If Not tmpRS.EOF Then
    getEmpID = tmpRS("EmployeeID")
Else
    getEmpID = ""
End If
tmpRS.Close
Set tmpRS = Nothing
End Function
Private Function getSuppID(ByVal strName As String) As String
Dim tmpRS As Recordset
RSOpen tmpRS, "SELECT SupplierID FROM Suppliers WHERE Name='" & strName & "';", dbOpenSnapshot
If Not tmpRS.EOF Then
    getSuppID = tmpRS("SupplierID")
Else
    getSuppID = ""
End If
tmpRS.Close
Set tmpRS = Nothing
End Function

Public Sub addItem(ByVal strID As String, ByVal strDes As String, ByVal strRef As String, ByVal qty As Integer, ByVal strLabel As String, ByVal strPrice As String)
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) = qty
        .Item(.Count).SubItems(4) = strLabel
        .Item(.Count).SubItems(5) = Format$(strPrice, "#,##0.00")
        adjustSum CSng(strPrice * qty)
        displayTotal
        numItems = numItems + 1
    End With
End If

End Sub
Private Sub supplier_Click()
If supplier.Text <> "" Then
    supplier.Tag = getSuppID(supplier.Text)
End If
End Sub

Private Sub adjustSum(sngAmount As Single)
purchaseSum = purchaseSum + sngAmount
End Sub

Private Sub displayTotal()
total.Text = Format$(purchaseSum, "#,##0.00")
End Sub