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 <tn1@BellSouth.net> ' Option Explicit 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, you must pass it By Value. 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, you must pass it By Value. 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