VERSION 4.00 Begin VB.Form frmOrder Appearance = 0 'Flat BackColor = &H00C0C0C0& Caption = "Place Order" ClientHeight = 4920 ClientLeft = 1005 ClientTop = 1185 ClientWidth = 8325 BeginProperty Font name = "MS Sans Serif" charset = 1 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H80000008& Height = 5325 Left = 945 LinkTopic = "Form1" MaxButton = 0 'False ScaleHeight = 4920 ScaleWidth = 8325 Top = 840 Width = 8445 Begin VB.Data CustProdHist Appearance = 0 'Flat Caption = "CustProdHist" Connect = "" DatabaseName = "C:\VBPROJ\SAMS\VB4DB.MDB" Exclusive = 0 'False Height = 270 Left = 720 Options = 0 ReadOnly = 0 'False RecordsetType = 1 'Dynaset RecordSource = "CustProdHist" Top = 4560 Visible = 0 'False Width = 2535 End Begin VB.CommandButton btnDelTickets Caption = "&Close" Height = 615 Left = 6120 TabIndex = 7 Top = 3600 Width = 1815 End Begin VB.TextBox txtDelDate Height = 375 Left = 5640 TabIndex = 6 Top = 3000 Width = 1335 End Begin VB.Data CustThisOrder Appearance = 0 'Flat Caption = "CustThisOrder" Connect = "" DatabaseName = "C:\VBPROJ\SAMS\VB4DB.MDB" Exclusive = 0 'False Height = 270 Left = 3960 Options = 0 ReadOnly = 0 'False RecordsetType = 1 'Dynaset RecordSource = "CustThisOrder" Top = 4320 Visible = 0 'False Width = 3135 End Begin VB.CommandButton cmdPrintOrder Appearance = 0 'Flat BackColor = &H80000005& Caption = "&Print This Order" Height = 615 Left = 4080 TabIndex = 1 Top = 3600 Width = 1815 End Begin VB.Data CustProd Appearance = 0 'Flat Caption = "CUSTPROD" Connect = "" DatabaseName = "C:\VBPROJ\SAMS\VB4DB.MDB" Exclusive = 0 'False Height = 270 Left = 3960 Options = 0 ReadOnly = 0 'False RecordsetType = 1 'Dynaset RecordSource = "CustProd" Top = 4560 Visible = 0 'False Width = 3135 End Begin MSDBGrid.DBGrid OrderHistoryGrid Bindings = "FRMDELIV.frx":0000 Height = 975 Left = 360 OleObjectBlob = "FRMDELIV.frx":0015 TabIndex = 9 Top = 360 Width = 7575 End Begin MSDBGrid.DBGrid ThisOrder Bindings = "FRMDELIV.frx":0E60 Height = 975 Left = 360 OleObjectBlob = "FRMDELIV.frx":0E76 TabIndex = 8 Top = 1800 Width = 7575 End Begin Crystal.CrystalReport rptOrderTicket Left = 3480 Top = 4320 _extentx = 741 _extenty = 741 _stockprops = 0 reportfilename = "" destination = 0 windowleft = 100 windowtop = 100 windowwidth = 490 windowheight = 300 windowtitle = "" windowborderstyle= 2 windowcontrolbox= -1 'True windowmaxbutton = -1 'True windowminbutton = -1 'True copiestoprinter = 1 printfilename = "" printfiletype = 0 selectionformula= "" groupselectionformula= "" connect = "" username = "" End Begin Threed.SSPanel pnlDelivMsg Height = 1215 Left = 120 TabIndex = 5 Top = 2880 Width = 3255 _version = 65536 _extentx = 5741 _extenty = 2143 _stockprops = 15 caption = "Gathering Order Information" BeginProperty font {FB8F0823-0164-101B-84ED-08002B2EC713} name = "MS Sans Serif" charset = 1 weight = 700 size = 18 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty End Begin VB.Label Label2 Alignment = 2 'Center Appearance = 0 'Flat BackColor = &H00808000& BorderStyle = 1 'Fixed Single Caption = "Current Order" ForeColor = &H00FFFFFF& Height = 255 Left = 360 TabIndex = 4 Top = 1560 Width = 7575 End Begin VB.Label Label13 Alignment = 1 'Right Justify Appearance = 0 'Flat BackColor = &H00C0C0C0& Caption = "Ship date" ForeColor = &H80000008& Height = 255 Left = 4560 TabIndex = 3 Top = 3120 Width = 975 End Begin VB.Label lblPrntMsg Alignment = 2 'Center Appearance = 0 'Flat BackColor = &H00FF0000& BorderStyle = 1 'Fixed Single Caption = "Loading Print Engine" BeginProperty Font name = "MS Sans Serif" charset = 1 weight = 700 size = 12 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H00FFFFFF& Height = 495 Left = 120 TabIndex = 2 Top = 4080 Visible = 0 'False Width = 3375 End Begin VB.Label Label1 Alignment = 2 'Center Appearance = 0 'Flat BackColor = &H00808000& BorderStyle = 1 'Fixed Single Caption = "Past Orders" ForeColor = &H00FFFFFF& Height = 255 Left = 360 TabIndex = 0 Top = 120 Width = 7575 End Attribute VB_Name = "frmOrder" Attribute VB_Creatable = False Attribute VB_Exposed = False Private Sub btnDelTickets_Click() Dim buffer As String MousePointer = 11 ' hourglass ' Delete any blank records which might exist for this customer in ' CustProd buffer = "Delete * From CustProd Where CustomerNum = " & Str(Customer_number) buffer = buffer & " AND IsNull(product);" CustDB.Execute (buffer) Unload frmOrder End Sub Private Sub cmdPrintOrder_Click() Dim Tbl As TABLE ' general purpose table pointer Dim CustomerTbl As TABLE ' table pointer to the custmain table Dim CustProdHistTbl As TABLE ' table pointer for the general order history Dim CustOrdMstTbl As TABLE ' table pointer for the master list of orders Dim CustOrdDtlTbl As TABLE ' table pointer for the order detail Dim CustThisOrderTbl As TABLE ' table pointer for the current order table Dim OrdersTbl As TABLE ' Table pointer for the ORDERS table Dim dynset As Dynaset ' dynaset for customer order history Dim Flag As Integer ' Indicator for whether we have checked the history or not Dim buffer As String ' Query string to pass execute statements Dim OrderNumber As Long ' the invoice/order number Dim mboxresp ' result from message box responses Dim CustOrdStr ' string for the customer order Dim histrecnum ' Counter for the history record we are on Dim deldate ' date to check for deleting old history records On Error GoTo deliverr mboxresp = MsgBox("Confirmed Order on " & txtDelDate.TEXT & "?", vbYesNo, "Confirm Order Date") If mboxresp <> vbYes Then Exit Sub End If MousePointer = 11 ' hourglass ' Display a message explaining something ' is happening. This routine can take a ' few seconds. To keep the user from pressing ' the buttons on the screen, make them invisible ' and put the "loading Print Engine" label over ' them. lblPrntMsg.Left = 4200 lblPrntMsg.TOP = 3600 lblPrntMsg.Visible = True cmdPrintOrder.Visible = False btnDelTickets.Visible = False DoEvents ' Clear out any records contained in CUSTORDMST and CUSTORDDTL CustDB.Execute ("Delete * From CustOrdMst;") CustDB.Execute ("Delete * From CustOrdDtl;") Set CustOrdMstTbl = CustDB.OpenTable("CustOrdMst") Set CustOrdDtlTbl = CustDB.OpenTable("CustOrdDtl") Set CustomerTbl = CustDB.OpenTable("CustMain") Set CustThisOrderTbl = CustDB.OpenTable("CustThisOrder") Set CustProdHistTbl = CustDB.OpenTable("CustProdHist") Set OrdersTbl = CustDB.OpenTable("Orders") ' Find the customer record CustomerTbl.Index = "PrimaryKey" CustomerTbl.Seek "=", Customer_number If (CustomerTbl.NoMatch = True) Then MsgBox ("The customer you have selected is not in the database.") MousePointer = 0 ' default Exit Sub End If ' Add a record to ORDERS. This must be done before the CUSTORDMST ' record is added because an order number is needed. OrdersTbl.AddNew OrdersTbl.Fields("CustomerNum") = Customer_number OrdersTbl.Fields("Date") = txtDelDate.TEXT OrdersTbl.Fields("Description") = "Order" OrdersTbl.Fields("Charge") = CustThisOrder.Recordset.Fields("Total") OrdersTbl.UPDATE ' Update the current balance Call CalculateCurrentBalance ' Now retrieve the order number of the order just placed in ORDERS OrdersTbl.Index = "PrimaryKey" OrdersTbl.Seek "<=", 9999999 ' Populate the CUSTORDMST table CustOrdMstTbl.AddNew CustOrdMstTbl.Fields("CustomerNum") = Customer_number CustOrdMstTbl.Fields("InvoiceDate") = txtDelDate.TEXT CustOrdMstTbl.Fields("OrderNum") = OrdersTbl.Fields("OrderNum") CustOrdMstTbl.UPDATE ' Populate the CUSTORDDTL table. One record for each record contained ' in CUSTTHISORDER CustThisOrderTbl.MoveFirst While (CustThisOrderTbl.EOF = False) CustOrdDtlTbl.AddNew CustOrdDtlTbl.Fields("OrderNum") = OrdersTbl.Fields("OrderNum") CustOrdDtlTbl.Fields("product") = CustThisOrderTbl.Fields("product") CustOrdDtlTbl.Fields("Qty") = CustThisOrderTbl.Fields("Qty") CustOrdDtlTbl.Fields("Price") = CustThisOrderTbl.Fields("Price") CustOrdDtlTbl.Fields("Subtotal") = CustThisOrderTbl.Fields("Subtotal") CustOrdDtlTbl.Fields("Tax") = CustThisOrderTbl.Fields("Tax") CustOrdDtlTbl.Fields("Deposit") = CustThisOrderTbl.Fields("Deposit") CustOrdDtlTbl.Fields("Total") = CustThisOrderTbl.Fields("Total") CustOrdDtlTbl.UPDATE ' Now add a record to CustProdHist. To keep the the filesize ' down, limit the history to the last 10 records. ' If more than 10 unique orders exist ' for the current customer, remove the earliest orders ' until there are only 10. If (Flag = False) Then ' "Flag" is False which means I have not yet checked to see if ' there are 10 unique orders for the current customer. buffer = "SELECT DISTINCT OrderNum, CustomerNum, Date_Delivered FROM CustProdHist WHERE " buffer = buffer & "((CustProdHist.CustomerNum = " & Str(Customer_number) & ")) " buffer = buffer & " Order By Date_Delivered" Set dynset = CustDB.CreateDynaset(buffer) If (dynset.RecordCount > 0) Then dynset.MoveLast End If If (dynset.RecordCount >= 10) Then dynset.MoveFirst deldate = dynset.Fields("Date_Delivered") If deldate Then buffer = "Delete * From CustProdHist Where CustomerNum = " & Str(CustProdHistTbl.Fields("CustomerNum")) & " AND " buffer = buffer & "Date_Delivered = " & dynset.Fields("Date_Delivered") CustDB.Execute (buffer) Else buffer = "Delete * from CustProdHist where CustomerNum = " & Str(CustProdHistTbl.Fields("CustomerNum")) & " AND " buffer = buffer & "product = NULL" CustDB.Execute (buffer) End If End If Flag = True End If CustProdHistTbl.AddNew CustProdHistTbl.Fields("CustomerNum") = Customer_number CustProdHistTbl.Fields("Date_Delivered") = txtDelDate.TEXT CustProdHistTbl.Fields("product") = CustThisOrderTbl.Fields("Product") CustProdHistTbl.Fields("Qty") = CustThisOrderTbl.Fields("Qty") CustProdHistTbl.Fields("OrderNum") = OrdersTbl.Fields("OrderNum") CustProdHistTbl.UPDATE CustThisOrderTbl.MoveNext Wend rptOrderTicket.ReportFileName = "c:\vbproj\sams\ordtick.rpt" rptOrderTicket.WindowTitle = "Printing Order Ticket" rptOrderTicket.Destination = 0 '1=printer, 0=screen rptOrderTicket.Action = 1 lblPrntMsg.Visible = False cmdPrintOrder.Visible = True btnDelTickets.Visible = True CustProdHist.Refresh MousePointer = 0 ' default Exit Sub deliverr: MsgBox ("Error printing this Order ticket: " & Err.Description) lblPrntMsg.Visible = False cmdPrintOrder.Visible = True btnDelTickets.Visible = True CustProdHist.Refresh MousePointer = 0 ' default End Sub Private Sub Form_Activate() Dim SQLCustProdHistInq Dim CustProdRTEDynaset As Dynaset Dim CustProdTbl As TABLE Dim CustThisOrdTbl As TABLE Dim buffer As String ' Reset to the default pointer when returning to this form. MousePointer = 0 If IsNull(CustmainDynaset.Fields("Last_Name")) <> True Then frmOrder.Caption = "Order information for " & CustmainDynaset.Fields("Last_Name") Else If IsNull(CustmainDynaset.Fields("Company")) <> True Then frmOrder.Caption = "Order information for " & CustmainDynaset.Fields("Company") Else frmOrder.Caption = "Order Information" End If End If ' The process of looking up stuff could take a few ' seconds (especially if there are a lot of orders), ' so put up a message telling the user what is going on. pnlDelivMsg.Visible = True ' Set up the Product history data control SQLCustProdHistInq = "Select * from CustProdHist where CustomerNum = " & Customer_number & ";" CustProdHist.RecordSource = SQLCustProdHistInq CustProdHist.Refresh ' Insert a record in the CustThisOrder. Set CustThisOrderTbl = CustDB.OpenTable("CustThisOrder") CustThisOrderTbl.AddNew CustThisOrderTbl.Fields("CustomerNum") = Customer_number CustThisOrderTbl.UPDATE CustThisOrder.Refresh ' Set the delivery date to be tomorrow txtDelDate.TEXT = Format$(Now + 1, "dd-mmm-yy") ' Turn off the message saying we are looking ' up stuff. pnlDelivMsg.Visible = False End Sub Private Sub Form_Load() 'Center the form Left = (Screen.Width - Width) / 2 TOP = (Screen.Height - Height) / 2 End Sub Private Sub OrderHistoryGrid_BeforeDelete(Cancel As Integer) Dim response As Integer response = MsgBox("Are you sure you want to delete this record?", vbYesNo + vbQuestion, "Delete") If response = vbYes Then Exit Sub Else Cancel = True End If End Sub