frmmain.frm

英文版Access数据库编程

Public Sub loadRecDeliveries()
'loads the 10 most recent deliveries
With lvDeliveries
    .View = lvwReport
    .ColumnHeaders.Clear
    .ColumnHeaders.add , , "DO No."
    .ColumnHeaders.add , , "Customer"
    .ColumnHeaders(2).width = 2000
    .ColumnHeaders.add , , "Date"
    .ColumnHeaders.add , , "Status"
    
    Dim recentRS As Recordset, recentSQL As String
    recentSQL = "SELECT Delivery.DOnumber, Delivery.Date, Customers.Name, Delivery.Status " & _
                "FROM Customers INNER JOIN Delivery ON Customers.CustomerID = Delivery.CustomerID " & _
                "WHERE Delivery.Status='DELIVERING' ORDER BY Delivery.Date DESC"
    On Error GoTo ErrHandler
    .ListItems.Clear
    RSOpen recentRS, recentSQL, dbOpenSnapshot
    While Not recentRS.EOF
        .ListItems.add , , recentRS("DOnumber")
        .ListItems(.ListItems.Count).SubItems(1) = recentRS("Name")
        .ListItems(.ListItems.Count).SubItems(2) = recentRS("Date")
        .ListItems(.ListItems.Count).SubItems(3) = recentRS("Status")
        recentRS.MoveNext
    Wend
    recentRS.Close
    Set recentRS = Nothing
End With
ErrHandler:
If Err.Number <> 0 Then
    lvDeliveries.ListItems.add , , "ERROR"
    lvDeliveries.ListItems(lvDeliveries.ListItems.Count).SubItems(1) = "AN ERROR HAS OCCURED. UNABLE TO LOAD RECENT DELIVERIES"
    Exit Sub
End If
End Sub

Private Sub performSearch()
Dim strCriteria As String, searchSQL As String
Dim criteriaNum As Integer, NumRecords As Integer
Dim searchRS As Recordset
criteriaNum = 0
strCriteria = txtSearch.Text
Select Case cmbCondition.Text
    Case "Delivery Order"
        criteriaNum = 1
        searchSQL = "SELECT Delivery.DOnumber, Customers.Name, Delivery.PONumber, Delivery.DelDate, Delivery.DelTime, Delivery.Status FROM Customers INNER JOIN Delivery ON Customers.CustomerID = Delivery.CustomerID WHERE ((DOnumber LIKE '*" & strCriteria & "*') OR (PONumber LIKE '*" & strCriteria & "*') OR (Attn LIKE '*" & strCriteria & "*') OR (Remark LIKE '*" & strCriteria & "*'));"
    Case "Purchase Order"
        criteriaNum = 2
        searchSQL = "SELECT Purchase.poNumber, Suppliers.Name, Purchase.Date FROM Suppliers INNER JOIN Purchase ON Suppliers.SupplierID=Purchase.SupplierID WHERE (Purchase.poNumber LIKE '" & strCriteria & "') OR (Suppliers.Name LIKE '" & strCriteria & "') OR (Purchase.Date LIKE '" & strCriteria & "');"
    Case "Product"
        criteriaNum = 3
        searchSQL = "SELECT * FROM Products WHERE ((ProductID LIKE '*" & strCriteria & "*') OR (Description LIKE '*" & strCriteria & "*') OR (Brand LIKE '*" & strCriteria & "*') OR (CategoryID LIKE '*" & strCriteria & "*'));"
End Select
If criteriaNum > 0 Then
    'Open recordset to see if query returns result
    RSOpen searchRS, searchSQL, dbOpenSnapshot
    'Proceed if not end of file
    If Not searchRS.EOF Then
        searchRS.MoveLast
        NumRecords = searchRS.RecordCount
        If criteriaNum = 1 Then
            frmDelivery_Main.Show , frmMain
            frmDelivery_Main.getDeliveries searchSQL
        ElseIf criteriaNum = 3 Then
            frmProduct_Browse.Show , frmMain
            frmProduct_Browse.showListofProducts searchSQL
        End If
        InfoMsg "Search completed. " & NumRecords & " matching record(s) found.", "Search complete"
    Else
        InfoMsg "No matching record found based on search string provided. Please try again.", "No record found"
        txtSearch.SetFocus
    End If
    searchRS.Close
    Set searchRS = Nothing
Else
    ValidMsg "Please specify a search criteria.", "Missing criteria"
End If
End Sub

Private Sub Command1_Click()
If Len(txtSearch.Text) > 0 Then
    performSearch
Else
    ValidMsg "Please enter a keyword for search. Example: Bearing A222", "Missing keyword"
    txtSearch.SetFocus
End If
End Sub

Private Sub Form_Load()
prevHour = Hour(Now())
lblWelcome.Caption = "Welcome " & CurrentUser.strUsername
checkAccStatus
implementSystemPolicy
loadRecDeliveries
loadTicker
Dim i As Integer
For i = 0 To 4
    Set Image2(i).Picture = img32.ListImages(7).Picture
Next i
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If MsgBox("All windows will be closed and unsaved delivery orders, etc would be destroyed." & vbCrLf & "Are you sure you want to quit now? ", vbYesNoCancel + vbQuestion, "Quit") <> vbYes Then
    Cancel = True
End If
End Sub

Private Sub Form_Resize()
frmTick.width = Me.width
bgWelcome.height = Me.height
End Sub

Private Sub Form_Unload(Cancel As Integer)
tickerStop
Dim tempSQL As String
'Because users might just click on x button to close form
With MySynonDatabase
    'Begin writting of system logging here.
    insertLog "User logged off"
    
    tempSQL = "UPDATE Users SET Users.status = 'OFFLINE' " & _
            "WHERE (([Username]='" & CurrentUser.strUsername & "'));"
    .Execute tempSQL
End With
closeDB
Set frmMain = Nothing
End 'Ends the process of the application
End Sub

Private Sub lvDeliveries_DblClick()
With lvDeliveries
If .ListItems.Count > 0 Then
    If .SelectedItem.Selected Then
        frmDelivery_Main.Show
        frmDelivery_Main.getDeliveries "SELECT Delivery.DOnumber, Customers.Name, Delivery.PONumber, Delivery.DelDate, Delivery.DelTime, Delivery.Status FROM Customers INNER JOIN Delivery ON Customers.CustomerID = Delivery.CustomerID WHERE DOnumber='" & .SelectedItem.Text & "';"
    End If
End If
End With
End Sub

Private Sub mnu_Help_Help_Click()
InfoMsg "This version currently do not have an updated help file. Sorry for the inconvenience caused.", "Not Available"
End Sub

Private Sub mnu_Invoicing_Click()
frmInvoicing.Show vbModal
End Sub

Private Sub mnu_Payable_Order_Click()
Dim p As frmPurchase
Set p = New frmPurchase
Load p
p.Show
End Sub

Private Sub mnu_Payable_Suppliers_Click()
frmSuppliers.Show vbModal
End Sub

Private Sub mnu_Payable_View_Click()
frmPurchases_Main.Show
End Sub

Private Sub receivables_Click()
Call mnu_Receivable_Delivery_Click
End Sub

Private Sub txtSearch_GotFocus()
SelText txtSearch
End Sub

Private Sub txtSearch_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyReturn Then
    Call Command1_Click
End If
End Sub

Private Sub users_Click()
Call mnu_Admin_Users_Click
End Sub

Private Sub human_Click()
Call mnu_Human_Employees_Click
End Sub

Private Sub inventory_Click()
Call mnu_Inventory_Browse_Click
End Sub

Private Sub po_Click()
Call mnu_Payable_Order_Click
End Sub

Private Sub Image2_Click(Index As Integer)
Select Case Index
    Case 0
        receivables_Click
    Case 1
        po_Click
    Case 2
        inventory_Click
    Case 3
        human_Click
    Case 4
        users_Click
End Select
End Sub

Private Sub mnu_Add_PublicTicker_Click()
frmTicker_New.Show vbModal
End Sub

Private Sub mnu_Admin_Logs_Click()
frmAdmin_Logging.Show vbModal
End Sub

Private Sub mnu_Admin_Settings_Click()
frmAdmin_Settings.Show vbModal
End Sub

Private Sub mnu_Admin_SQL_Click()
frmAdmin_SQL.Show vbModal
End Sub

Private Sub mnu_Admin_Users_Click()
frmUsers_Main.Show
End Sub

Private Sub mnu_Contracts_Click(Index As Integer)
With mnu_Contracts
    If .Item(Index).Caption <> "--{NONE}--" Then
        Dim newF As frmConsignment_Browse
        Set newF = frmConsignment_Browse
        Load newF
        newF.Caption = newF.Caption & " " & .Item(Index).Caption
        newF.getConsignmentDetails .Item(Index).Tag
        newF.Show
    End If
End With
End Sub

Private Sub mnu_Database_Backup_Click()
Dim strFileName As String
InfoMsg "Before attempting to backup the database, ensure no one else is logged on to the system" & _
"because any updates made would not be recorded or captured by the system.", "Warning"

With cDialog

    .DialogTitle = "Backup database"
    .filter = "Access Database (*.mdb)|*.mdb|All Files (*.*)|*.*"
    .Flags = cdlOFNHideReadOnly + cdlOFNOverwritePrompt + cdlOFNPathMustExist
    .FilterIndex = 1
    .CancelError = False
    .ShowSave
    On Error GoTo ErrHandler
    If .FileName <> "" Then
        Screen.MousePointer = 11
        Dim strTarget As String
        'On Error GoTo ErrHandler
        'mysynondatabase
        MkDir App.Path & Format$(Now(), "dd") & Format$(Now(), "MMMM") & Format$(Now(), "YYYY")
        insertLog "Database backup."
        InfoMsg "The database has been successfully backup.", "Database backup"
    End If
End With
Screen.MousePointer = 0

ErrHandler:
If Err.Number <> 0 Then
    ErrorNotifier Err.Number, Err.description
End If
End Sub

Private Sub mnu_Database_Restore_Click()
With cDialog
    ' Sets the Dialog Title
    .DialogTitle = "Restore Database"
    
    ' Sets the filter to Access database only
    .filter = "Access Database (*.mdb)|*.mdb|All Files (*.*)|*.*"
    
    ' Set the default files type to databases
    .FilterIndex = 1
    
    ' Sets the flags - File must exist and Hide Read only
    .Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
    
    ' Set dialog box so an error occurs if the dialogbox is cancelled
    .CancelError = False
    
    ' Enables error handling to catch cancel error
    On Error GoTo ErrHandler
    ' display the dialog box
    .ShowOpen
    If .FileName <> "" Then
        Dim sTarget As String 'Open button is clicked
        sTarget = .FileName
        If MsgBox("Are you sure you want to restore the database with this backup copy?" & vbCrLf & sTarget, vbQuestion + vbYesNo, "Restore") = vbYes Then
            'Copy the backup to the default database location.
            Screen.MousePointer = 11
            On Error GoTo ErrHandler
            FileCopy sTarget, DBLocation
            insertLog "Database restored."
            InfoMsg "The database has been successfully restored.", "Database restored"
        End If
    End If
Screen.MousePointer = 0
End With

ErrHandler:
If Err.Number <> 0 Then
    ErrorNotifier Err.Number, Err.description
End If
End Sub

Private Sub mnu_Help_About_Click()
frmAbout.Show vbModal
End Sub

Private Sub mnu_Human_Browse_Click()
frmLeave_Browse.Show vbModal
End Sub

Private Sub mnu_Human_Employees_Click()
frmEmployees.Show
End Sub

Private Sub mnu_Human_Leave_Click()
frmLeave_Apply.Show vbModal
End Sub

Private Sub mnu_Human_Payrol_Click()
frmPayroll_New.Show vbModal
End Sub

Private Sub mnu_Inventory_Browse_Click()
Load frmProduct_Browse
frmProduct_Browse.WindowState = vbMaximized
frmProduct_Browse.Show
End Sub

Private Sub mnu_Inventory_Categories_Click()
frmCategory_Browse.Show vbModal
End Sub

Private Sub mnu_Inventory_Contracts_Click()
frmConsignment_Main.Show
End Sub

Private Sub mnu_Main_Inventory_Click()
Dim invRS As Recordset
Dim i As Integer
For i = mnu_Contracts.LBound To mnu_Contracts.UBound
    If i <> 0 Then
        Unload mnu_Contracts(i)
    End If
Next i
On Error GoTo ErrHandler
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_Contracts(i).Caption = invRS("Name")
    mnu_Contracts(i).Tag = invRS("ContractNo")
    invRS.MoveNext
    If Not invRS.EOF Then
        i = i + 1
        Load mnu_Contracts(i)
    End If
Wend
invRS.Close
Set invRS = Nothing
ErrHandler:
If Err.Number <> 0 Then
    ErrorNotifier Err.Number, Err.description
End If
End Sub

Private Sub mnu_Maintenance_Cities_Click()
frmCities.Show vbModal
End Sub

Private Sub mnu_Maintenance_Countries_Click()
frmCountries.Show vbModal
End Sub

Private Sub mnu_Maintenance_States_Click()
frmStates.Show vbModal
End Sub

Private Sub mnu_Manage_Ticker_Click()
frmTickers.Show vbModal
End Sub

Private Sub mnu_Option_Password_Click()
Load frmPassword
frmPassword.setFormMode = mild_Change
frmPassword.Show vbModal
End Sub

Private Sub mnu_Options_Quit_Click()
Unload Me
End Sub

Private Sub mnu_Options_Refresh_Click()
loadRecDeliveries
End Sub

Private Sub mnu_Payable_Add_Click()
Load frmSupplier_New
frmSupplier_New.Show vbModal
End Sub

Private Sub mnu_Personal_Ticker_Click()
frmTicker_Personal.Show vbModal
End Sub

Private Sub mnu_Receivable_Add_Click()
Load frmCustomer_New
frmCustomer_New.Show vbModal
End Sub

Private Sub mnu_Receivable_Customers_Click()
frmCustomers.Show
End Sub

Private Sub mnu_Receivable_Delivery_Click()
Dim f As frmDelivery
Set f = New frmDelivery
Load f
f.Show
End Sub

Private Sub mnu_Receivable_View_Click()
frmDelivery_Main.Show , frmMain
End Sub

Private Sub mnu_Report_Main_Click()
frmReport_Main.Show , frmMain
End Sub

Private Sub tmrTicker_Timer()
Dim currHour As Byte
currHour = Hour(Now())
If currHour > prevHour Then 'Refreshes every hour
    prevHour = currHour
    destroyTicker
    loadTicker
End If
moveTicker 15
End Sub