Attribute VB_Name = "Sample1" '-- '-- Sample1.bas '-- Note: This Sample is just one module of a larger application. '-- Because referenced classes and/or modules are not available, '-- references to User Defined Types will not be resolved and '-- corresponding errors will be generated by any attempt to '-- run or compile this code. In addition, some lines have been '-- removed from the source code to reduce the size of the sample '-- while still demonstrating the formatting capabilities of '-- FormatVB. Jim Holloman '-- Option Explicit '-- $Reformatted by FormatVB, Ver. 0.9, on 09-03-99 at 13:46:25 Public Const scPREV_INSTANCE_RUNNING = "Cannot run more than one instance of this application. Please use the currently running one." Private Const icINVALID_PARM_COUNT = 123 Private Const scSQ = "'" Private Const scCS = ", " Private Const scNULL = "NULL" Private Const scKeyPrefix = "ID=" '-- Modes for frmActor Public Enum ACTOR_MODE icADD_ADDRESS = 1 icEDIT_ADDRESS = 2 icDISPLAY_ADDRESS = 3 icADD_CUSTOMER = 4 icDISPLAY_CUSTOMER = 5 icEDIT_CUSTOMER = 6 icADD_EMPLOYEE = 7 icDISPLAY_EMPLOYEE = 8 icEDIT_EMPLOYEE = 9 icADD_SUPPLIER = 10 icEDIT_PASSWORD = 11 icDISPLAY_SUPPLIER = 12 icEDIT_SUPPLIER = 13 End Enum '-- Modes for frmActors Public Enum ACTORS_MODE icGET_CUSTOMER = 1 icGET_SUPPLIER = 2 icGET_EMPLOYEE = 3 End Enum '-- Modes for frmOrder Public Enum ORDER_MODE icBASE_MENU = 1 icADD_PURCHASE_ORDER = 2 icDISPLAY_PURCHASE_ORDER = 3 icDISPLAY_SALES_ORDER = 6 End Enum '-- Modes for frmOrders Public Enum ORDERS_MODE icPURCHASE_ORDERS = 1 icSALES_ORDERS = 2 End Enum '-- Column types for VToSQL Private Enum COL_TYPE icDATE = 1 icFOREIGN_KEY = 2 icNUMBER = 3 icOTHER = 4 icSTRING = 5 icNON_EMPTY_STRING = 6 End Enum '-- Registry API functions: Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _ (ByVal hKey As Long, _ ByVal lpValueName As String) As Long Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _ (ByVal hKey As Long, _ ByVal lpSubKey As String, _ ByVal ulOptions As Long, _ ByVal samDesired As Long, _ phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _ (ByVal hKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ lpType As Long, _ ByVal lpData As String, _ lpcbData As Long) As Long ' Note that if you declare the lpData parameter as String Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" _ (ByVal hKey As Long, _ ByVal lpValueName As String, _ ByVal Reserved As Long, _ ByVal dwType As Long, _ ByVal lpData As String, _ ByVal cbData As Long) As Long ' Note that if you declare the lpData parameter as String Private Declare Function RegCreateKeyEx& Lib "advapi32.dll" Alias "RegCreateKeyExA" _ (ByVal hKey As Long, _ ByVal lpSubKey As String, _ ByVal Reserved As Long, _ ByVal lpClass As String, _ ByVal dwOptions As Long, _ ByVal samDesired As Long, _ ByVal Security As Long, _ phkResult As Long, _ lpdwDisposition As Long) Public Function Insert(Optional oContact As cContact, _ Optional oCustomer As cCustomer, _ Optional oEmployee As cEmployee) _ As Boolean '-- Insert contact, customer or employee data object into database Dim iPrms As Integer Dim sQry As String '-- Initialize return value Insert = False '-- Allow only one parameter iPrms = 0 If Not oEmployee Is Nothing Then iPrms = iPrms + 1 End If If iPrms <> 1 Then Err.Raise icINVALID_PARM_COUNT, OBJNAME, scINVALID_PARM_COUNT Exit Function End If If Not oContact Is Nothing Then '-- Inserting a Contact '-- Construct SQL statement With oContact sQry = "INSERT INTO contacts (ContactType, LastName, FirstName, Address1, Address2, City, State, ZipCode, PhoneNumber) VALUES (" & _ VToSQL(.ContactType, icNON_EMPTY_STRING) & _ scCS & VToSQL(.LastName, icNON_EMPTY_STRING) & _ scCS & VToSQL(.FirstName, icNON_EMPTY_STRING) & _ scCS & VToSQL(.Address1, icNON_EMPTY_STRING) & _ scCS & VToSQL(.PhoneNumber, icNON_EMPTY_STRING) & _ ")" End With '-- Execute query and return success If ExecQuery(scDSN, sQry) Then _ Insert = True Exit Function End If If Not oCustomer Is Nothing Then '-- Inserting a Customer '-- Construct SQL statement With oCustomer sQry = "INSERT INTO customers (NickName, LastName, FirstName, Address1, Address2, City, State, ZipCode, PhoneNumber) VALUES (" & _ VToSQL(.NickName, icNON_EMPTY_STRING) & _ scCS & VToSQL(.LastName, icNON_EMPTY_STRING) & _ scCS & VToSQL(.FirstName, icNON_EMPTY_STRING) & _ scCS & VToSQL(.Address1, icNON_EMPTY_STRING) & _ scCS & VToSQL(.PhoneNumber, icNON_EMPTY_STRING) & _ ")" End With '-- Execute query and return success If ExecQuery(scDSN, sQry) Then _ Insert = True Exit Function End If If Not oEmployee Is Nothing Then '-- Inserting an Employee '-- Construct SQL statement With oEmployee sQry = "INSERT INTO employees (Alias, LastName, Firstname, MI, SSN, Address1, Address2, City, State, ZipCode, HomePhone, CellPhone, EmergencyContact, EmergencyPhone, HireDate, Password) VALUES (" & _ VToSQL(.Alias, icNON_EMPTY_STRING) & _ scCS & VToSQL(.LastName, icNON_EMPTY_STRING) & _ scCS & VToSQL(.FirstName, icNON_EMPTY_STRING) & _ scCS & VToSQL(.MI, icNON_EMPTY_STRING) & _ scCS & VToSQL(.SSN, icNON_EMPTY_STRING) & _ scCS & VToSQL(.Address1, icNON_EMPTY_STRING) & _ scCS & VToSQL(.Address2, icNON_EMPTY_STRING) & _ scCS & VToSQL(.Password, icNON_EMPTY_STRING) & _ ")" End With '-- Execute query and return success If ExecQuery(scDSN, sQry) Then _ Insert = True Exit Function End If End Function Public Function InsertOrder(oOrder As cOrder, _ cOrderDetails As cOrderDetails) _ As Boolean '-- Insert an order and order details into database Dim lOrderId As Long ' Note that these comments stay Dim lErrNo As Long ' aligned for simple datatypes even Dim sErrDesc As String ' though the datatypes are shifted Dim oConn As ADODB.Connection ' This demonstrates the Dim oRset As ADODB.Recordset ' alignment of appended comments Dim oOrderDet As cOrderDetail ' in Dim Groups for Dim oOrderDet2 As cOrderDetail2 ' complex Dim oOrderDet2B As cOrderDetail2B ' datatypes Dim lOrderId As Long ' Note that these comments stay Dim lErrNo As Long ' aligned for simple datatypes even Dim sErrDesc As String ' though the datatypes are shifted Dim nCtr As Integer ' An Integer Counter Dim mflgEditFlag As Boolean ' Edit Flag Dim mflgInEdit As Boolean ' Another Boolean Type Dim cAmount As Currency ' What happens with Currency Type? '-- default to false for function InsertOrder = False '-- enable error handler On Error GoTo ErrorHandler '-- Get connection Set oConn = New ADODB.Connection oConn.Open scDSN oConn.BeginTrans Set oRset = New ADODB.Recordset Set oRset.ActiveConnection = oConn oRset.CursorType = adOpenKeyset oRset.LockType = adLockOptimistic oRset.Open "Orders", , , , adCmdTable '-- record to orders table oRset.AddNew With oOrder If .CustomerId Then _ oRset!CustomerId = .CustomerId If .EmployeeId Then _ oRset!EmployeeId = .EmployeeId If .SupplierId Then _ oRset!SupplierId = .SupplierId If .OrderDate Then _ oRset!OrderDate = .OrderDate If .Status <> vbNullString Then _ oRset!Status = .Status If .SubTotal Then _ oRset!SubTotal = .SubTotal If .ShippingHandling Then _ oRset!ShippingHandling = .ShippingHandling If .Tax Then _ oRset!Tax = .Tax If .Total Then _ oRset!Total = .Total If .IsSales Then _ oRset!IsSales = .IsSales End With oRset.Update '-- get PKId from order record for order details lOrderId = oRset!PKId oRset.Close Set oRset = Nothing Set oRset = New ADODB.Recordset Set oRset.ActiveConnection = oConn oRset.CursorType = adOpenKeyset oRset.LockType = adLockBatchOptimistic oRset.Open "OrderDetails", , , , adCmdTable For Each oOrderDet In cOrderDetails oRset.AddNew With oOrderDet oRset!OrderId = lOrderId oRset!ItemId = .ItemId oRset!UnitPrice = .UnitPrice oRset!Quantity = .Quantity End With oRset.Update Next oRset.UpdateBatch oRset.Close Set oRset = Nothing oConn.CommitTrans oConn.Close Set oConn = Nothing '-- looks like everything worked so set success and exit InsertOrder = True Exit Function '-- if we're here there then's been an error so process ErrorHandler: '-- store incoming values lErrNo = Err.Number sErrDesc = Err.Description '-- roll back the transaction, close connection, and signal failure On Error Resume Next oConn.RollbackTrans oConn.Close InsertOrder = False On Error GoTo 0 Err.Raise lErrNo, OBJNAME, sErrDesc End Function Public Function Update(Optional oContact As cContact, _ Optional oCustomer As cCustomer, _ Optional oEmployee As cEmployee, _ Optional oOrder As cOrder) _ As Boolean '-- Update contact, customer, employee or order in database Dim iPrms As Integer Dim sQry As String '-- Initialize return value Update = False '-- Allow only one parameter iPrms = 0 If Not oContact Is Nothing Then iPrms = iPrms + 1 End If If Not oCustomer Is Nothing Then iPrms = iPrms + 1 End If If Not oEmployee Is Nothing Then iPrms = iPrms + 1 End If If Not oOrder Is Nothing Then iPrms = iPrms + 1 End If If iPrms <> 1 Then Err.Raise icINVALID_PARM_COUNT, OBJNAME, scINVALID_PARM_COUNT Exit Function End If If Not oContact Is Nothing Then '-- Updating a Contact With oContact sQry = "UPDATE Contacts SET " & _ scCONTACT_TYPE & " = " & VToSQL(.ContactType, icNON_EMPTY_STRING) & _ scCS & scLAST_NAME & " = " & VToSQL(.LastName, icNON_EMPTY_STRING) & _ scCS & scFIRST_NAME & " = " & VToSQL(.FirstName, icNON_EMPTY_STRING) & _ scCS & scLAST_CONTACT & " = " & VToSQL(.LastContact, icDATE) & _ " WHERE PKId=" & .PKId End With If ExecQuery(scDSN, sQry) Then _ Update = True Exit Function End If If Not oCustomer Is Nothing Then '-- Updating a Customer With oCustomer sQry = "UPDATE Customers SET " & _ scNICK_NAME & " = " & VToSQL(.NickName, icNON_EMPTY_STRING) & _ scCS & scLAST_NAME & " = " & VToSQL(.LastName, icNON_EMPTY_STRING) & _ scCS & scFIRST_NAME & " = " & VToSQL(.FirstName, icNON_EMPTY_STRING) & _ scCS & scPHONE_NUMBER & " = " & VToSQL(.PhoneNumber, icNON_EMPTY_STRING) & _ " WHERE PKId=" & .PKId End With If ExecQuery(scDSN, sQry) Then _ Update = True Exit Function End If If Not oEmployee Is Nothing Then '-- Updating an Employee With oEmployee sQry = "UPDATE Employees SET " & _ scALIAS & " = " & VToSQL(.Alias, icNON_EMPTY_STRING) & _ scCS & scLAST_NAME & " = " & VToSQL(.LastName, icNON_EMPTY_STRING) & _ scCS & scFIRST_NAME & " = " & VToSQL(.FirstName, icNON_EMPTY_STRING) & _ scCS & scPASSWORD & " = " & VToSQL(.Password, icNON_EMPTY_STRING) & _ " WHERE PKId=" & .PKId End With If ExecQuery(scDSN, sQry) Then _ Update = True Exit Function End If If Not oOrder Is Nothing Then '-- Updating an Order With oOrder sQry = "UPDATE Orders SET " & _ scCUSTOMER_ID & " = " & VToSQL(.CustomerId, icFOREIGN_KEY) & _ scCS & scEMPLOYEE_ID & " = " & VToSQL(.EmployeeId, icFOREIGN_KEY) & _ scCS & scIS_SALES & " = " & VToSQL(.IsSales, icOTHER) & _ " WHERE PKId=" & .PKId End With If ExecQuery(scDSN, sQry) Then _ Update = True Exit Function End If End Function Public Function GetEmployee() As cEmployee '-- Return an employee object for employee logged in through launcher Dim oEmployee As cEmployee Dim oIniFile As SimuIniFile Dim oRecordset As ADODB.Recordset Dim sQry As String Dim sUser As String '-- Get alias of logged in employee from registry Set oIniFile = New SimuIniFile oIniFile.Scope = icSIF_USERSCOPE oIniFile.RootSpec = scUserRoot sUser = oIniFile.ReadProfileString("Alias", "") Set oIniFile = Nothing '-- Look up employee in database sQry = scSELECT_EMPLOYEE_BY_ALIAS & scSQ & sUser & scSQ If DataAccessAPI.GetRecordset(scDSN, sQry, oRecordset) Then If Not oRecordset.EOF Then oRecordset.MoveFirst Set oEmployee = New cEmployee With oEmployee .PKId = oRecordset!PKId If Not IsNull(oRecordset!Alias) Then _ .Alias = oRecordset!Alias If Not IsNull(oRecordset!LastName) Then _ .LastName = oRecordset!LastName If Not IsNull(oRecordset!FirstName) Then _ .FirstName = oRecordset!FirstName If Not IsNull(oRecordset!MI) Then _ .MI = oRecordset!MI If Not IsNull(oRecordset!SSN) Then _ .SSN = oRecordset!SSN If Not IsNull(oRecordset!HireDate) Then _ .HireDate = oRecordset!HireDate If Not IsNull(oRecordset!Password) Then _ .Password = oRecordset!Password End With End If End If Set oRecordset = Nothing '-- Return employee object Set GetEmployee = oEmployee Set oEmployee = Nothing End Function Public Function GetItem(ByVal lItemId As Long) As cItem '-- Return an item for itemId Dim oItem As cItem Dim oRecordset As ADODB.Recordset Dim sQry As String If lItemId Then sQry = "SELECT * FROM Items WHERE Items.PKID=" & lItemId If DataAccessAPI.GetRecordset(scDSN, sQry, oRecordset) Then If oRecordset.RecordCount Then oRecordset.MoveFirst Set oItem = New cItem With oItem .PKId = oRecordset!PKId If Not IsNull(oRecordset!ItemTypeId) Then _ .ItemTypeId = oRecordset!ItemTypeId If Not IsNull(oRecordset!AuthorId) Then _ .AuthorId = oRecordset!AuthorId If Not IsNull(oRecordset!PublisherId) Then _ .PublisherId = oRecordset!PublisherId If Not IsNull(oRecordset!SupplierId) Then _ .SupplierId = oRecordset!SupplierId If Not IsNull(oRecordset!KeyWords) Then _ .KeyWords = oRecordset!KeyWords End With End If Set oRecordset = Nothing End If End If Set GetItem = oItem Set oItem = Nothing End Function Public Function GetListCustomers() As cCustomers '-- Return a collection of customers from database Dim oCustomers As cCustomers Dim oRecordset As ADODB.Recordset Dim oCustomer As cCustomer '-- Init customers collection Set oCustomers = New cCustomers '-- Get customers from database '-- WriteToLog "OrderCommon.GetListCustomers - call DataAccessAPI.GetRecordset" If DataAccessAPI.GetRecordset(scDSN, scSELECT_CUSTOMERS, oRecordset) Then '-- WriteToLog "OrderCommon.GetListCustomers - done DataAccessAPI.GetRecordset" Do Until oRecordset.EOF Set oCustomer = New cCustomer With oCustomer .PKId = oRecordset!PKId If Not IsNull(oRecordset!NickName) Then _ .NickName = oRecordset!NickName If Not IsNull(oRecordset!LastName) Then _ .LastName = oRecordset!LastName If Not IsNull(oRecordset!LastSale) Then _ .LastSaleOrder = oRecordset!LastSale If Not IsNull(oRecordset!TotalSaleYTD) Then _ .TotalSalesYTD = oRecordset!TotalSaleYTD End With oCustomers.Add oCustomer, IDToKey(oCustomer.PKId) Set oCustomer = Nothing oRecordset.MoveNext Loop End If Set oRecordset = Nothing Set GetListCustomers = oCustomers Set oCustomers = Nothing End Function Public Function GetListEmployees() As cEmployees '-- Return a collection of employees from database Dim oEmployees As cEmployees Dim oRecordset As ADODB.Recordset Dim oEmployee As cEmployee '-- Init employees collection Set oEmployees = New cEmployees '-- Get employees from database If DataAccessAPI.GetRecordset(scDSN, scSELECT_EMPLOYEES, oRecordset) Then Do Until oRecordset.EOF Set oEmployee = New cEmployee With oEmployee .PKId = oRecordset!PKId If Not IsNull(oRecordset!Alias) Then _ .Alias = oRecordset!Alias If Not IsNull(oRecordset!LastName) Then _ .LastName = oRecordset!LastName If Not IsNull(oRecordset!FirstName) Then _ .FirstName = oRecordset!FirstName If Not IsNull(oRecordset!Password) Then _ .Password = oRecordset!Password End With oEmployees.Add oEmployee, IDToKey(oEmployee.PKId) Set oEmployee = Nothing oRecordset.MoveNext Loop End If Set oRecordset = Nothing Set GetListEmployees = oEmployees Set oEmployees = Nothing End Function Public Function GetListSuppliers() As cContacts '-- return a collection of suppliers from database Dim oSuppliers As cContacts Dim oRecordset As ADODB.Recordset Dim oSupplier As cContact '-- Init suppliers collection Set oSuppliers = New cContacts '-- Get suppliers from database If DataAccessAPI.GetRecordset(scDSN, scSELECT_SUPPLIERS, oRecordset) Then Do Until oRecordset.EOF Set oSupplier = New cContact With oSupplier .PKId = oRecordset!PKId If Not IsNull(oRecordset!ContactType) Then _ .ContactType = oRecordset!ContactType If Not IsNull(oRecordset!LastName) Then _ .LastName = oRecordset!LastName If Not IsNull(oRecordset!FirstName) Then _ .FirstName = oRecordset!FirstName If Not IsNull(oRecordset!LastContact) Then _ .LastContact = oRecordset!LastContact End With oSuppliers.Add oSupplier, IDToKey(oSupplier.PKId) Set oSupplier = Nothing oRecordset.MoveNext Loop End If Set oRecordset = Nothing Set GetListSuppliers = oSuppliers Set oSuppliers = Nothing End Function Public Function GetListOrders(ByVal iMode As ORDERS_MODE) As cOrders '-- Return a collection of orders from database Dim oOrder As cOrder Dim oOrders As cOrders Dim oRecordset As ADODB.Recordset Dim sQry As String '-- Init orders collection Set oOrders = New cOrders Select Case iMode Case ORDERS_MODE.icPURCHASE_ORDERS '-- Get purchase orders from database sQry = scSELECT_PURCHASE_ORDERS Case ORDERS_MODE.icSALES_ORDERS '-- Get sales orders from database sQry = scSELECT_SALES_ORDERS End Select If sQry <> vbNullString Then If DataAccessAPI.GetRecordset(scDSN, sQry, oRecordset) Then Do Until oRecordset.EOF Set oOrder = New cOrder With oOrder .PKId = oRecordset!PKId If Not IsNull(oRecordset!CustomerId) Then _ .CustomerId = oRecordset!CustomerId If Not IsNull(oRecordset!EmployeeId) Then _ .EmployeeId = oRecordset!EmployeeId If Not IsNull(oRecordset!SupplierId) Then _ .SupplierId = oRecordset!SupplierId If Not IsNull(oRecordset!OrderDate) Then _ .OrderDate = oRecordset!OrderDate If Not IsNull(oRecordset!IsSales) Then _ .IsSales = oRecordset!IsSales End With oOrders.Add oOrder, IDToKey(oOrder.PKId) Set oOrder = Nothing oRecordset.MoveNext Loop End If End If Set oRecordset = Nothing Set GetListOrders = oOrders Set oOrders = Nothing End Function Public Function GetOrderDetails(ByVal oOrder As cOrder) As cOrderDetails '-- Fill detail list for order Dim oOrderDetails As cOrderDetails Dim oRecordset As ADODB.Recordset Dim oOrderDet As cOrderDetail Dim sQry As String '-- Initialize order details collection Set oOrderDetails = New cOrderDetails If Not oOrder Is Nothing Then '-- Get order details from database if order has a PKId If oOrder.PKId Then '-- Prepare query expression for order details sQry = scSELECT_ORDER_DETAILS & oOrder.PKId '-- Get order details from database If DataAccessAPI.GetRecordset(scDSN, sQry, oRecordset) Then Do Until oRecordset.EOF Set oOrderDet = New cOrderDetail With oOrderDet oOrderDet.PKId = oRecordset!PKId If Not IsNull(oRecordset!OrderId) Then _ .OrderId = oRecordset!OrderId If Not IsNull(oRecordset!ItemId) Then _ .ItemId = oRecordset!ItemId If Not IsNull(oRecordset!Quantity) Then _ .Quantity = oRecordset!Quantity If Not IsNull(oRecordset!UnitPrice) Then _ .UnitPrice = oRecordset!UnitPrice End With oOrderDetails.Add oOrderDet, OrderCommon.IDToKey(oOrderDet.PKId) Set oOrderDet = Nothing oRecordset.MoveNext Loop End If Set oRecordset = Nothing End If End If Set GetOrderDetails = oOrderDetails Set oOrderDetails = Nothing End Function Public Function IDToKey(ByVal lId As Long) As String '-- Return a string based on LId for use as a key IDToKey = scKeyPrefix & lId End Function Private Function VToSQL(ByVal vVar,iType As COL_TYPE) As String '-- Return a string for use in SQL expressions from VToSQL = vbNullString Select Case iType Case COL_TYPE.icDATE If vVar Then VToSQL = scSQ & CStr(vVar) & scSQ Else VToSQL = scNULL End If Case COL_TYPE.icFOREIGN_KEY If vVar Then VToSQL = CStr(vVar) Else VToSQL = scNULL End If Case COL_TYPE.icNUMBER VToSQL = CStr(vVar) Case COL_TYPE.icOTHER VToSQL = CStr(vVar) Case COL_TYPE.icSTRING VToSQL = scSQ & DoQuotes(vVar) & scSQ Case COL_TYPE.icNON_EMPTY_STRING If vVar = vbNullString Then VToSQL = scNULL Else VToSQL = scSQ & DoQuotes(vVar) & scSQ End If End Select End Function Private Function DoQuotes(ByVal sData As String) As String '-- Return string with single quotes doubled up for use in SQL statements Dim iLast As Integer Dim sPart As String If Len(sData) = 0 Then _ Exit Function iLast = InStr(sData, scSQ) While iLast sPart = sPart & Left$(sData, iLast - 1) & scSQ & scSQ sData = Right$(sData, Len(sData) - iLast) iLast = InStr(sData, scSQ) Wend sData = sPart & sData DoQuotes = Trim$(sData) End Function Sub WriteToLog(ByVal sMsg As String) '-- Write message to log file Dim iFile As Integer iFile = FreeFile Open App.Path & "\" & App.Title & ".log" For Append As #iFile Print #iFile, sMsg Close #iFile End Sub