frmproduct_browse.frm

英文版Access数据库编程

Option Explicit
Private Function FormCount(ByVal frmName As String) As Long
    Dim frm As Form
    For Each frm In Forms
        If StrComp(frm.Name, frmName, vbTextCompare) = 0 Then
            FormCount = FormCount + 1
        End If
    Next
End Function

Public Sub formatListView()
With lvInventory
    .View = lvwReport
    .ColumnHeaders.add , , "ID", 960
    .ColumnHeaders.add , , "Description", 3500
    .ColumnHeaders.add , , "Brand", 1500
    .ColumnHeaders.add , , "Category ID", 1500
    .ColumnHeaders.add , , "Quantity", 900
    .ColumnHeaders.add , , "Min Level", 900
    .ColumnHeaders.add , , "Reorder Level", 1200
    .ColumnHeaders.add , , "Location", 1500
    If getSettings("allowPrice") = "TRUE" Then
        .ColumnHeaders.add , , "Unit Price", 900
    End If
End With

End Sub
Public Sub showListofProducts(ByVal paramSQL As String)
lvInventory.ListItems.Clear

Dim listRS As Recordset

RSOpen listRS, paramSQL, dbOpenSnapshot
'On Error GoTo ErrHandler
While Not listRS.EOF
    setPercentage listRS.PercentPosition
    With lvInventory
        .ListItems.add , , listRS("ProductID")
        .ListItems(.ListItems.Count).SubItems(1) = IIf(IsNull(listRS("Description")), "", listRS("Description"))
        .ListItems(.ListItems.Count).SubItems(2) = IIf(IsNull(listRS("Brand")), "", listRS("Brand"))
        .ListItems(.ListItems.Count).SubItems(3) = listRS("CategoryID")
        .ListItems(.ListItems.Count).SubItems(4) = IIf(IsNull(listRS("Quantity")), "0", listRS("Quantity"))
        .ListItems(.ListItems.Count).SubItems(5) = IIf(IsNull(listRS("MinLevel")), "0", listRS("MinLevel"))
        .ListItems(.ListItems.Count).SubItems(6) = IIf(IsNull(listRS("ReorderLevel")), "0", listRS("ReorderLevel"))
        .ListItems(.ListItems.Count).SubItems(7) = IIf(IsNull(listRS("Location")), "", listRS("Location"))
        If getSettings("allowPrice") = "TRUE" Then 'If allowed to see price
            .ListItems(.ListItems.Count).SubItems(8) = Format$(IIf(IsNull(listRS("UnitPrice")), "0", listRS("UnitPrice")), "#,##0.00")
        End If
    End With
    listRS.MoveNext
Wend
listRS.Close
Set listRS = Nothing
setPercentage 0

ErrHandler:
If Err.Number <> 0 Then
    'Possible errors occuring during runtime
    ErrorNotifier Err.Number, Err.description
    setPercentage 0
End If
End Sub

Private Sub setPercentage(ByVal valPercent As Single)
pbBar.Value = valPercent
If valPercent = 0 Then
    lblPercent.Caption = ""
Else
    lblPercent.Caption = Format$(valPercent, "00.00\%")
End If
End Sub

Public Sub getValues()
'Obtain values from list view for further references
With lvInventory
    lblID.Caption = .SelectedItem.Text
    lblDescription.Caption = .SelectedItem.SubItems(1)
    lblBrand.Caption = .SelectedItem.SubItems(2)
    lblCategoryID.Caption = .SelectedItem.SubItems(3)
    lblQuantity.Text = .SelectedItem.SubItems(4)
    lblMin.Text = .SelectedItem.SubItems(5)
    lblReorder.Text = .SelectedItem.SubItems(6)
    lblLocation.Caption = .SelectedItem.SubItems(7)
    If getSettings("allowPrice") = "TRUE" Then
        lblUnitPrice.Caption = .SelectedItem.SubItems(8)
    End If
End With
End Sub

Public Sub clearValues()
'Clears the values within product info section
lblID.Caption = ""
lblDescription.Caption = ""
lblBrand.Caption = ""
lblCategoryID.Caption = ""
lblQuantity.Text = ""
lblMin.Text = ""
lblReorder.Text = ""
lblLocation.Caption = ""
lblUnitPrice.Caption = ""
optIn.Value = False
optOut.Value = False
txtQuantity.Text = ""
End Sub

Public Sub setStatus(ByVal strMessage As String)
bar.Panels(bar.Panels.Count).Text = strMessage
End Sub

Private Sub cmbFilter_Click()
If (IsNull(cmbFilter.Text) = True) Or (cmbFilter.Text <> "") Then
    showListofProducts "SELECT * FROM Products WHERE CategoryID='" & cmbFilter.Text & "';"
    clearValues
End If
End Sub

Private Sub cmdDone_Click()
If lblDescription.Caption = "" Then 'Indicates no product selected
    ValidMsg "Please select a product first.", "No product selected."
    lvInventory.SetFocus
'check if options selected
ElseIf ((optIn.Value = False) And (optOut.Value = False)) Then
    ValidMsg "Please select an option of adding or deducting stock.", "Missing selection"
    optIn.SetFocus
ElseIf Len(txtQuantity.Text) = 0 Then 'check if quantity entered.
    ValidMsg "Please enter a quantity of the selected stock.", "Missing entry"
    txtQuantity.SetFocus
ElseIf ((Val(txtQuantity.Text) < 1) Or (Val(txtQuantity.Text) > 30000)) Then
    ValidMsg "Please enter a value for quantity between 0 and 30000.", "Invalid value"
    txtQuantity.SetFocus
ElseIf (optOut.Value = True) And (Val(txtQuantity.Text) > Val(lblQuantity.Text)) Then
    ValidMsg "Please enter a value that do not exceed the amount available in store.", "Invalid value"
    txtQuantity.SetFocus
Else
    'Begin saving
    Dim tempSQL As String, tmpMessage As String
    Dim oldQty As Integer, tmpQty As Integer
    Dim tRS As Recordset
    tmpQty = CInt(txtQuantity.Text)
    On Error GoTo ErrHandler
    BeginTrans
    tempSQL = "SELECT Quantity FROM Products WHERE ProductID='" & lblID.Caption & "';"
    Set tRS = MySynonDatabase.OpenRecordset(tempSQL, dbOpenDynaset, dbDenyWrite)
    If Not tRS.EOF Then
        tRS.Edit
        oldQty = CInt(tRS("Quantity"))
        If optIn.Value = True Then
            tRS("Quantity") = oldQty + tmpQty
            tempSQL = "INSERT INTO Internal_Transaction VALUES('" & Format$(Now(), "dd/mm/yyyy") & "','" & lblID.Caption & "',True," & tmpQty & ");"
        Else
            tRS("Quantity") = oldQty - tmpQty
            tempSQL = "INSERT INTO Internal_Transaction VALUES('" & Format$(Now(), "dd/mm/yyyy") & "','" & lblID.Caption & "',False," & tmpQty & ");"
        End If
        tRS.Update
        'updates the transaction log
        MySynonDatabase.Execute tempSQL
        CommitTrans
        'inform user through status bar
        setStatus "Product ID: " & lblID.Caption & " has been updated!"
        'Clear the screen
        clearValues
        Call cmbFilter_Click
        tRS.Close
        Set tRS = Nothing
    End If
End If

ErrHandler:
If Err.Number <> 0 Then
    Rollback
    ErrorNotifier Err.Number, Err.description & vbNewLine & "The changes have not been made."
End If
End Sub

Private Sub Form_Load()
formatListView
FillCombo cmbFilter, "SELECT Categories.CategoryID FROM Categories;", "CategoryID"
cmbFilter.ListIndex = 0
Call cmbFilter_Click
End Sub

Private Sub Form_Resize()
On Error Resume Next
lvInventory.width = Me.width - (480 + Frame1.width)
lvInventory.height = Me.ScaleHeight - (250 + bar.height)
Frame1.Left = Me.width - (250 + Frame1.width)
optIn.Left = Frame1.Left + 120
optOut.Left = optIn.Left
optIn.Top = Frame1.Top + 300
optOut.Top = optIn.Top + optIn.height + 105
cmdDone.Left = Frame1.Left + 1200
cmdDone.Top = Frame1.Top + 1320
Frame2.Left = Frame1.Left
Frame3.Left = Frame1.Left
bar.Panels(1).width = Me.width
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set frmProduct_Browse = Nothing
End Sub

Private Sub lvInventory_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
With lvInventory '// change to the name of the list view
    Static iLast As Integer, iCur As Integer
    .Sorted = True
    iCur = ColumnHeader.Index - 1
    If iCur = iLast Then .SortOrder = IIf(.SortOrder = 1, 0, 1)
    .SortKey = iCur
    iLast = iCur
End With
End Sub

Private Sub lvInventory_DblClick()
With lvInventory
    If .ListItems.Count > 0 Then
        If .SelectedItem.Selected Then
            Load frmProduct_Details
            frmProduct_Details.getProductDetails lblID.Caption
            frmProduct_Details.Show vbModal
        End If
    End If
End With
End Sub

Private Sub lvInventory_ItemClick(ByVal Item As MSComctlLib.ListItem)
With Item
    If .Selected Then
        getValues
    Else
        clearValues
    End If
End With
End Sub

Private Sub lvInventory_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbRightButton Then
    If lvInventory.SelectedItem.Selected Then
        PopupMenu mnu_Delivery, vbPopupMenuLeftAlign
    End If
End If
End Sub

Private Sub mnu_Delivery_Click()
If lblID.Caption = "" Then
    mnu_Delivery_Add.Enabled = False
    mnu_Purchase_Add.Enabled = False
Else
    mnu_Delivery_Add.Enabled = True
    mnu_Purchase_Add.Enabled = True
    'Deal with delivery orders and purchase orders
    Dim i As Integer, j As Integer, frm As Form
    For i = mnu_ExistingDO.LBound To mnu_ExistingDO.UBound
        If i = 0 Then
            mnu_ExistingDO(i).Caption = "--{NONE}--"
        Else
            Unload mnu_ExistingDO(i)
        End If
    Next i
    For j = mnu_ExistingPO.LBound To mnu_ExistingPO.UBound
        If j = 0 Then
            mnu_ExistingPO(j).Caption = "--{NONE}--"
        Else
            Unload mnu_ExistingPO(j)
        End If
    Next j
    'Loads the number of menu equal to the current number of DO/PO forms
    i = 0
    j = 0
    For Each frm In Forms
        If Left$(frm.Tag, 2) = "DO" Then
            If i > 0 Then
                Load mnu_ExistingDO(i)
            End If
            mnu_ExistingDO(i).Caption = "New Delivery Order - " & frm.Tag
            mnu_ExistingDO(i).Tag = frm.Tag
            i = i + 1
        ElseIf Left$(frm.Tag, 2) = "PO" Then
            If j > 0 Then
                Load mnu_ExistingPO(j)
            End If
            mnu_ExistingPO(i).Caption = "New Purchase Order - " & frm.Tag
            mnu_ExistingPO(i).Tag = frm.Tag
            j = j + 1
        End If
    Next
    'Deal with consignments
    Dim invRS As Recordset
    For i = mnu_Insert.LBound To mnu_Insert.UBound
        If i <> 0 Then
            Unload mnu_Insert(i)
        End If
    Next i
    RSOpen invRS, "SELECT Contracts.ContractNo, Customers.Name FROM Customers INNER JOIN Contracts ON Customers.CustomerID=Contracts.CustomerID", dbOpenSnapshot
    i = 0
    While Not invRS.EOF
        mnu_Insert(i).Caption = invRS("Name")
        mnu_Insert(i).Tag = invRS("ContractNo")
        invRS.MoveNext
        If Not invRS.EOF Then
            i = i + 1
            Load mnu_Insert(i)
        End If
    Wend
    invRS.Close
    Set invRS = Nothing
End If

End Sub

Private Sub mnu_ExistingDO_Click(Index As Integer)
If mnu_ExistingDO(Index).Caption <> "--{NONE}--" Then
    frmSelected.add lvInventory.SelectedItem, mnu_ExistingDO(Index).Tag
End If
End Sub

Private Sub mnu_ExistingPO_Click(Index As Integer)
If mnu_ExistingPO(Index).Caption <> "--{NONE}--" Then
    frmSelectedForPO.add lvInventory.SelectedItem, mnu_ExistingPO(Index).Tag
End If
End Sub

Private Sub mnu_Insert_Click(Index As Integer)
If lblID.Caption <> "" Then
    If mnu_Insert.Count > 0 Then
        If MsgBox("Are you sure you want to add this product into " & mnu_Insert(Index).Caption & " consignment contract? " & vbCrLf & "The initial quantity will be 0 and it may be removed from the consignment anytime.", vbYesNo + vbQuestion, "Add to consignment") = vbYes Then
            Dim insertSQL As String, insertRS As Recordset
            With lvInventory.SelectedItem
                On Error Resume Next
                RSOpen insertRS, "SELECT ProductID FROM C_Details WHERE ProductID='" & .Text & "' AND ContractNo='" & mnu_Insert(Index).Tag & "';", dbOpenSnapshot
                insertRS.MoveFirst
                insertRS.MoveLast
                If insertRS.RecordCount = 0 Then
                    insertSQL = "INSERT INTO C_Details VALUES ('" & mnu_Insert(Index).Tag & "','" & .Text & "','',0,0,0,'')"
                    MySynonDatabase.Execute insertSQL
                    If Err.Number <> 0 Then
                        CriticalMsg "Unable to add product into consignment. Please try again.", "Error found"
                    Else
                        InfoMsg "Product has been successfully inserted into the consignment.", "Record inserted"
                    End If
                Else 'Already in there
                    ValidMsg "The product is already available in the consignment inventory.", "Record exist"
                End If
                insertRS.Close
                Set insertRS = Nothing
            End With
        End If
    End If
End If
End Sub

Private Sub mnu_New_Click()
Dim f As frmDelivery
Set f = New frmDelivery
Load f
f.Show , frmMain
End Sub

Private Sub mnu_New_PO_Click()
Dim p As frmPurchase
Set p = New frmPurchase
Load p
p.Show , frmMain

End Sub

Private Sub mnu_Options_Add_Click()
frmProduct_New.Show vbModal
End Sub

Private Sub mnu_Options_Close_Click()
Unload Me
End Sub

Private Sub mnu_Refresh_Click()
cmbFilter_Click
End Sub

Private Sub txtQuantity_GotFocus()
SelText txtQuantity
End Sub

Private Sub txtQuantity_KeyPress(KeyAscii As Integer)
OnlyNum KeyAscii
End Sub

Private Sub txtQuantity_LostFocus()
If txtQuantity.Text = "" Then
    txtQuantity.Text = "0"
End If
End Sub