A good way to learn Visual Basic techniques is to study complex code that has been developed and tested by someone else. In the Conrad Systems Contacts and Housing Reservations sample databases, you can find dozens of examples of complex Visual Basic code that perform various tasks. The following sections describe two of the more interesting ones in detail.
You’ve probably noticed a lot of sample data in both the Conrad Systems Contacts and the Housing Reservations databases. No, we didn’t sit at our keyboards for hours entering sample data! Instead, we built a Visual Basic procedure that accepts some parameters entered on a form. In both databases, the form to load sample data is saved as zfrmLoadData. If you open this form in Contacts.accdb from the Navigation Pane, you’ll see that you use it to enter a beginning date, a number of days (max 365), a number of companies to load (max 25), a maximum number of contacts per company (max 10), and a maximum number of events per contact (max 25). You can also select the check box to delete all existing data before randomly loading new data. (The zfrmLoadData form in the Housing Reservations database offers some slightly different options.) Figure 19–15 shows this form with the values we used to load the Conrad Systems Contacts database.
Figure 19–15: The zfrmLoadData form in the Conrad Systems Contacts sample database makes it easy to load sample data.
As you might expect, when you click the Load button, our procedure examines the values entered and loads some sample data into tblCompanies, tblContacts, tblCompany-Contacts, tblContactEvents and tblContactProducts. The code picks random company names from ztblCompanies (a table containing a list of fictitious company names) and random person names from ztblPeople (a table containing names of Microsoft employees who have agreed to allow their names to be used in sample data). It also chooses random ZIP Codes (and cities, counties, and states) from tlkpZips (a table containing U.S. postal ZIP Code, city name, state name, county name, and telephone area codes as of December 2002 that we licensed from CD Light, LLC-www.zipinfo.com). Figure 19–16 shows you the design of the query used in the code to pick random person names.
Figure 19–16: This query returns person names in a random sequence.
The query creates a numeric value to pass to the Rnd (random) function by grabbing the first character of the LastName field and then calculating the ASCII code value. The Rnd function returns some floating-point random value less than 1 but greater than or equal to zero. Asking the query to sort on this random number results in a random list of values each time you run the query.
Note | If you open zqryRandomNames in Datasheet view, the RandNum column won’t appear to be sorted correctly. In fact, the values change as you scroll through the data or resize the datasheet window. The database engine actually calls the Rnd function on a first pass through the data to perform the sort Because the function depends on a value of one of the columns (LastName), Access assumes that other users might be changing this column-and therefore, the calculated result-as you view the data. Access calls the Rnd function again each time it refreshes the data display, so the actual values you see aren’t the ones that the query originally used to sort the data. |
If you want to run this code, you should either pick a date starting after July 9, 2007, or select the option to delete all existing records first.
You can find the code in the cmdLoad_Click event procedure that runs when you click the Load button on the zfrmLoadData form. We’ve added line numbers to some of the lines in this code listing in the book so that you can follow along with the line-by-line explanations in Table 19–5, which follows the listing. Because the code loads data into both a multi-value field and an attachment field in the tblContacts table, it uses the DAO object model exclusively. (You cannot manipulate multi-value or attachment fields using the ADO object model.)
1 Private Sub cmdLoad_CIick() 2 ' Code to load a random set of companies, ' contacts, events, and products ' Database variable 3 Dim db As DAO.Database ' Table delete list (if starting over) Dim rstDel As DAO.Recordset ' Company recordset; Contact recordset (insert only) Dim rstCo As DAO.Recordset, rstCn As DAO.Recordset ' Photo (attachment) and ContactType (multi-value) recordset Dim rstComplex As DAO.Recordset2 ' CompanyContact recordset, ContactEvent recordset (insert only) Dim rstCoCn As DAO.Recordset, rstCnEv As DAO.Recordset ' A random selection of zips Dim rstZipRandom As DAO.Recordset ' ..and company names Dim rstCoRandom As DAO.Recordset ' .. and people names Dim rstPRandom As DAO.Recordset ' A recordset to pick "close" zip codes for contacts Dim rstZipClose As DAO.Recordset ' A recordset to pick contact events Dim rstEvents As DAO.Recordset ' Place to generate Picture Path 4 Dim strPicPath As String ' Places for path to backend database and folder Dim strBackEndPath As String, strBackEndFolder As String ' Place to generate a safe "compact to" name Dim strNewDb As String ' Places to save values from the form controls Dim datBeginDate As Date, intNumDays As Integer Dim intNumCompanies As Integer, intNumContacts As Integer Dim intNumEvents As Integer ' Lists of street names and types 5 Dim strStreetNames(1 To 9) As String, strStreetTypes(1 To 5) As String ' As string of digits for street addresses and area codes Const strDigits As String = "1234567890" ' List of Person Titles by gender Dim strMTitles( To 6) As String, strFTitles( To 7) As String ' Place to put male and female picture file names Dim strMPicture() As String, intMPicCount As Integer Dim strFPicture() As String, intFPicCount As Integer ' Some working variables Dim intI As Integer, intJ As Integer, intK As Integer Dim intL As Integer, intM As Integer, intR As Integer Dim varRtn As Variant, intDefault As Integer Dim datCurrentDate As Date, datCurrentTime As Date ' Variables to assemble Company and Contact records Dim strCompanyName As String, strCoAddress As String Dim strAreaCode As String, strPAddress As String Dim strThisPhone As String, strThisFax As String Dim strWebsite As String Dim lngThisCompany As Long Dim lngThisContact As Long, strProducts As String ' Set up to bail if something funny happens (it shouldn't) 6 On Error GoTo BailOut ' Initialize Streets 7 strStreetNames(1) = "Main" strStreetNames(2) = "Central" strStreetNames(3) = "Willow" strStreetNames(4) = "Church" strStreetNames(8) = "Lincoln" strStreetNames(6) = "1st" strStreetNames(7) = "2nd" strStreetNames(8) = "3rd" strStreetNames(9) = "4th" strStreetTypes(1) = "Street" strStreetTypes(2) = "Avenue" strStreetTypes(3) = "Drive" strStreetTypes(4) = "Parkway" strStreetTypes(5) = "Boulevard" ' Initialize person titles strMTitles(1) = "Mr." strMTitles(2) = "Dr." strMTitles(3) = "Mr." strMTitles(4) = "Mr." strMTitles(5) = "Mr." strMTitles(6) = "Mr." strFTitles(1) = "Mrs." strFTitles(2) = "Dr." strFTitles(3) = "Ms." strFTitles(4) = "Mrs." strFTitles(5) = "Ms." strFTitles(6) = "Mrs." strFTitles(7) = "Ms." ' Search for male picture names (should be in Current Path\Pictures) 8 strPicPath = Dir(CurrentProject.Path &, "\Pictures\PersonM*.bmp") ' Loop until Dir returns nothing (end of list or not found) 9 Do Until (strPicPath = "") ' Add 1) to the count intMPicCount = intMPicCount + 1) ' Extend the file name array 10 ReDim Preserve strMPicture(1 To intMPicCount) ' Add the file name to the array strMPicture(intMPicCount) = strPicPath ' Get next one strPicPath = Dir 11 Loop ' Search for female picture names (should be in Current Path\Pictures) strPicPath = Dir(CurrentProject.Path &, "\Pictures\PersonF*.bmp") ' Loop until Dir returns nothing (end of list or not found) 12 Do Until (strPicPath = "") ' Add 1) to the count intFPicCount = intFPicCount + 1) ' Extend the file name array ReDim Preserve strFPicture(1 To intFPicCount) ' Add the file name to the array strFPicture(intFPicCount) = strPicPath ' Get next one strPicPath = Dir 13 Loop ' Capture values from the form 14 datBeginDate = CDate(Me.BeginDate) intNumDays = Me.NumDays intNumCompanies = Me.NumCompanies intNumContacts = Me.NumContacts intNumEvents = Me.NumEvents ' Open the current database 15 Set db = CurrentDb ' Do they want to delete old rows? 16 If (Me.chkDelete = -1) Then ' Verify it 17 If vbYes = MsgBox("Are you SURE you want to delete " &, _ "all existing rows? " &, vbCrLf &, vbCrLf &, _ "(This will also compact the data file.)", _ vbQuestion + vbYesNo + vbDefaultButton2, gstrAppTitle) Then ' Open the table that tells us the safe delete sequence 18 Set rstDel = db.OpenRecordset("SELECT * FROM " &, _ "ztblDeleteSeq ORDER BY Sequence", _ dbOpenSnapshot, dbForwardOnly) ' Loop through them all 19 Do Until rstDel.EOF ' Execute a delete 20 db.Execute "DELETE * FROM " &, rstDel!TableName, _ dbFailOnError ' Go to the next row rstDel.MoveNext Loop ' Figure out the path to the backend data 21 strBackEndPath = Mid(db.TableDefs("tblContacts").Connect, 11) ' Figure out the backend folder 22 strBackEndFolder = Left(strBackEndPath, _ InStrRev(strBackEndPath, "\")) ' Calculate a "compact to" database name strNewDb = "TempContact" &, Format(Now, "hhnnss") &, ".accdb" ' Compact the database into a new name 23 DBEngine.CompactDatabase strBackEndPath, _ strBackEndFolder &, strNewDb ' Delete the old one 24 Kill strBackEndPath ' Rename the new Name strBackEndFolder &, strNewDb As strBackEndPath Else ' Turn off the delete flag - changed mind Me.chkDelete = 0, 25 End If 26 End If ' Initialize the randomizer on system clock 27 Randomize ' Open all output recordsets 28 Set rstCo = db.OpenRecordset("tblCompanies", dbOpenDynaset) Set rstCn = db.OpenRecordset("tblContacts", dbOpenDynaset) Set rstCoCn = db.OpenRecordset("tblCompanyContacts", dbOpenDynaset) Set rstCnEv = db.OpenRecordset("tblContactEvents", dbOpenDynaset) ' Open the random recordsets Set rstZipRandom = db.OpenRecordset("zqryRandomZips", dbOpenDynaset) Set rstCoRandom = db.OpenRecordset("zqryRandomCompanies", dbOpenDynaset) Set rstPRandom = db.OpenRecordset("zqryRandomNames", dbOpenDynaset) ' Open the Events/products list Set rstEvents = db.OpenRecordset("zqryEventsProducts", dbOpenDynaset) ' Move to the end to get full recordcount rstEvents.MoveLast ' Turn on the hourglass 29 DoCmd.Hourglass True ' Initialize the status bar 30 varRtn = SysCmd(acSysCmdInitMeter, "Creating Companies...", _ intNumCompanies) ' Outer loop to add Companies 31 For intI = 1) To intNumCompanies ' Start a new company record rstCo.AddNew ' Clear the saved website strWebsite = "" ' Grab the next random "company" name 32 strCompanyName = rstCoRandom!CompanyName ' .. and the website 33 rstCo!Website = rstCoRandom!CompanyName & "#" & _ rstCoRandom!Web & "##" & rstCoRandom!CompanyName & " Website" strWebsite = rstCo!Website 34 rstCo!CompanyName = strCompanyName ' Generate a random street number 35 intR = Int((7 * Rnd) + 1) strCoAddress = Mid(strDigits, intR, 4) ' Now pick a random street name intR = Int((9 * Rnd) + 1) strCoAddress = strCoAddress & " " & strStreetNames(intR) ' and street type intR = Int((5 * Rnd) + 1) strCoAddress = strCoAddress & " " & strStreetTypes(intR) rstCo!Address = strCoAddress ' Fill in random values from the zip code table 36 rstCo!City = rstZipRandom!City rstCo!County = rstZipRandom!County rstCo!StateOrProvince = rstZipRandom!State rstCo!PostalCode = rstZipRandom!ZipCode ' Generate a random Area Code 37 intR = Int((8 * Rnd) + 1) strAreaCode = Mid(strDigits, intR, 3) ' Generate a random phone number (0100 - 0148) intR = Int((48 * Rnd) + 1) + 100 strThisPhone = strAreaCode & "555" & Format(intR, "0000") rstCo!PhoneNumber = strThisPhone ' Add 1 for the fax number strThisFax = strAreaCode & "555" & Format(intR + 1, "0000") rstCo!FaxNumber = strThisFax ' Save the new Company ID 38 lngThisCompany = rstCo!CompanyID ' .. and save the new Company rstCo.Update ' Now, do some contacts for this company ' - calc a random number of contacts 39 intJ = Int((intNumContacts * Rnd) + 1) ' Set up the recordset of Zips "close" to the Work Zip 40 Set rstZipClose = db.OpenRecordset("SELECT * FROM tlkpZips " & _ "WHERE ZipCode BETWEEN '" & _ Format(CLng(rstZipRandom!ZipCode) - 5, "00000") & _ "' AND '" & Format(CLng(rstZipRandom!ZipCode) + 5, "00000") & _ "'", dbOpenDyanaset) ' Move to last row to get accurate count rstZipClose.MoveLast ' Make the first contact the company default intDefault = True ' Loop to add contacts 41 For intK = 1 To intJ ' Start a new record rstCn.AddNew ' Put in the name info from the random people record 42 rstCn!LastName = rstPRandom!LastName rstCn!FirstName = rstPRandom!FirstName rstCn!MiddleInit = rstPRandom!MiddleInit rstCn!Suffix = rstPRandom!Suffix ' Select title and picture based on gender of person 43 If rstPRandom!Sex = "f" Then ' Pick a random female title and picture intR = Int((7 * Rnd) + 1) rstCn!Title = strFTitles(intR) ' Make sure we have some picture file names If intFPicCount <> 0 Then ' Pick a random file name intR = Int((intFPicCount * Rnd) + 1) strPicPath = strFPicture(intR) Else ' Set empty picture name strPicPath = "" End If 44 Else ' Pick a random male title and picture intR = Int((6 * Rnd) + 1) rstCn!Title = strMTitles(intR) ' Make sure we have some picture file names If intMPicCount <> 0 Then ' Pick a random file name intR = Int((intMPicCount * Rnd) + 1) strPicPath = strMPicture(intR) Else ' Set empty picture name strPicPath = "" End If 45 End If ' Set contact type to "Customer" – complex data type 46 Set rstComplex = rstCn!ContactType.Value rstComplex.AddNew rstComplex!Value = "Customer" rstComplex.Update 47 ' Copy the company website rstCn!Website = strWebsite ' Set up a dummy email rstCn!EmailName = rstPRandom!FirstName & " " & _ rstPRandom!LastName & mailto: & Left(rstPRandom!FirstName, 1) & _ rstPRandom!LastName & "@" _ Mid(rstCoRandom!Web, Instr(rstCoRandom!Web, http://www.) + 11) ' Strip off the trailing "/" rstCn!EmailName = Left(rstCn!EmailName, Len(rstCn!EmailName) – 1) ' Pick a random birth date between Jan 1, 1940 and Dec 31, 1979 ' There are 14,610 days between these dates intR = Int((14610 * Rnd) + 1) rstCn!BirthDate = #12/31/1939# + Int((14610 * Rnd) + 1) ' Set Default Address to 'work' rstCn!DefaultAddress = 1 ' Copy work address from Company rstCn!WorkAddress = strCoAddress rstCn!WorkCity = rstZipRandom!City rstCn!WorkStateOrProvince = rstZipRandom!State rstCn!WorkPostalCode = rstZipRandom!ZipCode rstCn!WorkPhone = strThisPhone rstCn!WorkFaxNumber = strThisFax ' Generate a random street number for home address intR = Int((7 * Rnd) + 1) strPAddress = Mid(strDigits, intR, 4) ' Now pick a random street name intR = Int((9 * Rnd) + 1) strPAddress = strPAddress & " " & strStreetNames(intR) ' and street type intR = Int((5 * Rnd) + 1) strPAddress = strPAddress & " " & strStreetTypes(intR) rstCn!HomeAddress = strPAddress ' Position to a "close" random zip 48 intR = rstZipClose.RecordCount intR = Int(intR * Rnd) rstZipClose.MoveFirst If intR > 0 Then rstZipClose.Move intR rstCn!HomeCity = rstZipClose!City rstCn!HomeStateOrProvince = rstZipClose!State rstCn!HomePostalCode = rstZipClose!ZipCode ' Generate a random phone number (0150 - 0198) intR = Int((48 * Rnd) + 1) + 149 rstCn!HomePhone = strAreaCode & "555" & Format(intR, "0000") ' Add 1 for the fax number rstCn!MobilePhone = strAreaCode & "555" & Format(intR + 1, "0000") ' Save the new contact ID 49 lngThisContact = rstCn!ContactID ' If got a random photo name, load it 50 If strPicPath <> "" Then ' Open the special photo editing recordset 51 Set rstComplex = rstCn!Photo.Value rstComplex.Addnew rstComplex!FileData.LoadFromFile _ (CurrentProject.Path & "\Pictures\" & strPicPath) rstComplex.Update End If ' Finally, save the row rstCn.Update ' Insert linking CompanyContact record 52 rstCoCn.AddNew ' Set the Company ID rstCoCn!CompanyID = lngThisCompany ' Set the Contact ID rstCoCn!ContactID = lngThisContact ' Make this the default company for the contact rstCoCn!DefaultForContact = True ' Set default for company - 1st contact will be the default rstCoCn!DefaultForCompany = intDefault ' Reset intDefault after first time through intDefault = False ' Save the linking row rstCoCn.Update ' Now, do some contacts events for this contact ' - calc a random number of events 53 intM = Int((intNumEvents * Rnd) + 1) ' Clear the Products sold string strProducts = "" ' Loop to add some events 54 For intL = 1 To intM ' Start a new row rstCnEv.AddNew ' Set the Contact ID rstCnEv!ContactID = lngThisContact ' Calculate a random number of days intR = Int(intNumDays * Rnd) datCurrentDate = datBeginDate + intR ' Calculate a random time between 8am and 8pm (no seconds) datCurrentTime = CDate(Format(((0.5 * Rnd) + 0.3333), "hh:nn")) ' Set the contact date/time rstCnEv!ContactDateTime = datCurrentDate + datCurrentTime 55 TryAgain: ' Position to a random event 56 intR = rstEvents.RecordCount intR = Int(intR * Rnd) rstEvents.MoveFirst If intR > 0 Then rstEvents.Move intR ' If a product sale event, 57 If (rstEvents!ContactEventProductSold = True) Then ' Can't sell the same product twice to the same contact If InStr(strProducts, _ Format(rstEvents!ContactEventProductID, "00")) <> 0 Then ' ooops. Loop back to pick a different event 58 GoTo TryAgain End If End If ' Set the Event Type 59 rstCnEv!ContactEventTypeID = rstEvents!ContactEventTypeID ' Set the follow-up rstCnEv!ContactFollowUp = rstEvents!ContactEventRequiresFollowUp ' Set the follow-up date If (rstEvents!ContactEventRequiresFollowUp = True) Then rstCnEv!ContactFollowUpDate = datCurrentDate + _ rstEvents!ContactEventFollowUpDays End If ' Save the record 60 rstCnEv.Update ' If this event is a product sale, 61 If (rstEvents!ContactEventProductSold = True) Then ' Call the routine to also add a product record! varRtn = Add_Product(lngThisCompany, lngThisContact, _ rstEvents!ContactEventProductID, datCurrentDate) ' Add the product to the products sold string strProducts = strProducts & " " & _ Format(rstEvents!ContactEventProductID, "00") End If ' Loop to do more events 62 Next intL ' Move to the next random person record 63 rstPRandom.MoveNext ' and loop to do more contacts 64 Next intK 65 rstZipClose.Close Set rstZipClose = Nothing ' Move to the next random zip record 66 rstZipRandom.MoveNext ' Update the status bar 67 varRtn = SysCmd(acSysCmdUpdateMeter, intI) ' Loop until done 68 Next intI ' Clear the status bar 69 varRtn = SysCmd(acSysCmdClearStatus) ' Done with error trapping, too On Error GoTo 0 ' Be nice and close everything up rstCo.Close Set rstCo = Nothing rstCn.Close Set rstCn = Nothing rstCoCn.Close Set rstCoCn = Nothing rstCnEv.Close Set rstCnEv = Nothing rstZipRandom.Close Set rstZipRandom = Nothing rstCoRandom.Close Set rstCoRandom = Nothing ' Turn off the hourglass 70 DoCmd.Hourglass False MsgBox "Done!", vbExclamation, gstrAppTitle DoCmd.Close acForm, Me.Name Exit Sub 71 BailOut: MsgBox "Unexpected error: " & Err & ", " & Error ' Turn off the hourglass DoCmd.Hourglass False varRtn = SysCmd(acSysCmdClearStatus) Resume Done 72 End Sub
Table 19–5 lists the statement line numbers and explains the code on key lines in the preceding Visual Basic code example.
Line | Explanation |
---|---|
1 | Declare the beginning of the subroutine. The subroutine has no arguments. |
2 | You can begin a comment anywhere on a statement line by preceding the comment with a single quotation mark. You can also create a comment statement using the Rem statement. |
3 | Declare local variables for a DAO Database object and all the DAO Recordset objects used in this code. |
4 | Beginning of the declarations of all local variables. You should always explicitly define variables in your code. |
5 | This procedure uses several arrays in which it stores street names, street types, male person titles, female person titles, and the paths to male and female pictures. Code later in the procedure randomly chooses values from these arrays. |
6 | Set an error trap; the BailOut label is at line 71. |
7 | Code to initialize the arrays begins here. Note that separate arrays handle male and female titles. |
8 | Use the Dir function to find available male picture names in the Pictures subfolder under the location of the current database. Note that if you move the sample database, this code won’t find any pictures to load. When Dir finds a matching file, it returns the file name as a string. The code subsequently calls Dir with no arguments inside the following loop to ask for the next picture. |
9 | Begin a loop to load male pictures, and keep looping until the picture file name is an empty string (Dir found no more files). |
10 | Note the use of ReDim Preserve to dynamically expand the existing file name array for male pictures without losing any entries already stored. |
11 | End of the loop started at statement number 9. |
12 | This loop finds all the female pictures available and loads them into the array that holds picture file names for females. |
13 | End of the loop started at statement number 12. |
14 | The next several lines of code capture the values from the form. Validation rules in the form controls make sure that the data is valid. |
15 | Initialize the Database object. |
16 | Check to see if you selected the option to delete all existing rows. |
17 | Use the MsgBox function to verify that you really want to delete existing data. |
18 | The ztblDeleteSeq table contains the table names in a correct sequence for deletes from the bottom up so that this code doesn’t violate any referential integrity rules. Note that the recordset is opened as a forward-only snapshot for efficiency. |
19 | Start a loop to process all the table names in ztblDeleteSeq. |
20 | Use the Execute method of the Database object to run the DELETE SQL commands. |
21 | Figure out the path to the linked data file by examining the Connect property of one of the linked tables. |
22 | Extract the folder name of the data file using the Left and InStrRev functions. |
23 | Use the CompactDatabase method of the DBEngine object to compact the data file into a new one-TempContacthhmmss.accdb-where hhmmss is the current time to avoid conflicts. |
24 | Use the Kill command to delete the old file and the Name command to rename the compacted temp copy. |
25 | Terminate the If statement on line 17. |
26 | Terminate the If statement on line 16. |
27 | Initialize the randomizer so that all random recordsets are always different. |
28 | Open all the recordsets needed in this code. |
29 | Turn the mouse pointer into an hourglass to let you know the transaction is under way and might take a while. You could also set the Screen.MousePointer property to 11 (busy). |
30 | The SysCmd utility function provides various useful options such as finding out the current directory for msaccess.exe (the Access main program), and the current version of Access. It also has options to display messages and a progress meter on the status bar. This code calls SysCmd to initialize the progress meter you see as the code loads the data. |
31 | Start the main loop to load company data. |
32 | Save the company name from the random recordset in a local variable. |
33 | Generate the Web site hyperlink from the company name and the Web field. |
34 | Set the company name in the new company record. |
35 | The next several lines of code use the Rnd function to randomly generate a four-digit street address and randomly choose a street name and street type from the arrays loaded earlier. |
36 | Grab the city, county, state, and ZIP Code from the current row in the random ZlP Code query. |
37 | Use Rnd again to generate a fake phone area code and phone and fax numbers. |
38 | The primary key of tblCompanies is an AutoNumber field. Access automatically generates the next number as soon as you update any field in a new record. This code saves the new company ID to use in related records and writes the company record with the Update method. |
39 | Calculate a random number of contacts to load for the new company based on the maximum you specified in the form. |
40 | Open a recordset that chooses the ZIP Codes that are 5 higher or lower than the random ZIP Code for the company. (It makes sense that the employees of the company live nearby.) |
41 | Start the loop to add contacts for this company. |
42 | Update the new contacts record with a random name plucked from the random person names query. |
43 | The records in the ztblPeople table have a gender field to help choose an appropriate title and picture for the contact. The statements following this If statement load female data, and the statements following the Else statement on line 44 load male data. |
44 | This Else statement matches the If on line 43. Statements following this choose male data. |
45 | This End If closes the If on line 43. |
46 | The ContactType field is a multi-value field, so must open a recordset on the field’s Value property even though we’re specifying only one value. |
47 | Finish generating fields for the contacts record, including the Web site copied from the company, a fake e-mail name, and a random birth date and addresses. |
48 | Choose a random ZIP Code for the contact near the company ZIP Code from the recordset opened on line 40. Also generate phone and fax numbers. |
49 | The primary key for tblContacts is also an AutoNumber field, so save the new value to use to generate related records and save the new contact. |
50 | If the code found a good picture file name earlier (male or female), then the following code adds that picture to the record. |
51 | Photo is an attachment field that works similarly to multi-value fields in code. The code opens a recordset and uses the LoadFromFile method to insert the picture using its file path. |
52 | Create the linking record in tblCompanyContacts from the saved CompanyID and ContactID. The first contact created is always the default contact for the company. |
53 | Calculate a random number of events to load for this contact. |
54 | Start the loop to add contact events. The following several lines calculate a random contact date and time within the range you specified on the form. |
55 | Code at line 58 goes here if the random product picked was already sold to this contact. |
56 | Choose a random event. |
57 | If the random event is a product sale, verify that this product isn’t already sold to this contact. A product can be sold to a contact only once. |
58 | The code loops back up to line 55 to choose another event if this is a duplicate product. |
59 | Finish updating the fields in the new contact event record. |
60 | Save the new contact event. |
61 | If the event was a product sale, call the Add_Product function that’s also in this form module to add a row to tblContactProducts. This code passes the company ID, contact ID, product ID, and the date of the event to the function. It also saves the product ID to be sure it isn’t sold again to this contact. |
62 | This Next statement closes the loop started on line 54. |
63 | Move to the next random person record. |
64 | Loop back up to line 41. |
65 | Close the recordset of ZIP Codes close to the company ZIP Code. |
66 | Get the next random ZIP Code for the next company. |
67 | Update the status bar to indicate your’re done with another company. |
68 | Loop back up to line 31. |
69 | Clear the status bar and close up shop. |
70 | Clear the hourglass set on line 29. Also issue the final MsgBox confirming that all data is now loaded. Finally, close this form and exit. |
71 | Any trapped error comes here. This code simply displays the error, clears the mouse pointer and the status bar, and exits. If you don’t reset the mouse pointer and clear the status bar, Access won’t do it for you! |
72 | End of the subroutine. |
In the Housing Reservations database (Housing.accdb), we created a function that dynamically creates a new table and then inserts into the table (using DAO) a complete list of all the error codes used by Access and the text of the error message associated with each error code. You can find a partial list of the error codes in Help, but the table in the Housing Reservations sample database provides the best way to see a list of all the error codes. You might find this table useful as you begin to create your own Visual Basic procedures and set error trapping in them.
Note | You can find the ADO equivalent of this example in the modExamples module in the Conrad Systems Contacts sample database. |
The name of the function is CreateErrTable, and you can find it in the modExamples module. The function statements are listed next. You can execute this function by entering the following in the Immediate window:
?CreateErrTable
The sample database contains the ErrTable table, so the code will ask you if you want to delete and rebuild the table. You should click Yes to run the code. Again, we’ve added line numbers to some of the lines in this code listing so that you can follow along with the line-by-line explanations in Table 19–6, which follows the listing.
1 Function CreateErrTable () ' This function creates a table containing a list of ' all the valid Access application error codes ' You can find the ADO version of this procedure in Contacts.accdb 2 ' Declare variables used in this function 3 Dim dbMyDatabase As DAO.Database, tblErrTable As DAO.TableDef, _ fldMyField As DAO.Field, idxPKey As DAO.Index 4 Dim rcdErrRecSet As DAO.Recordset, lngErrCode As Long, _ intMsgRtn As Integer 5 Dim varReturnVal As Variant, varErrString As Variant, _ ws As DAO.Workspace ' Create Errors table with Error Code and Error String fields ' Initialize the MyDatabase database variable ' to the current database 6 Set dbMyDatabase = CurrentDb 7 Set ws = DBEngine.Workspaces(0) ' Trap error if table doesn't exist ' Skip to next statement if an error occurs 8 On Error Resume Next 9 Set rcdErrRecSet = dbMyDatabase.OpenRecordset("ErrTable") 10 Select Case Err ' See whether error was raised 11 Case 0 ' No error-table must exist 12 On Error GoTo 0 ' Turn off error trapping 13 intMsgRtn = MsgBox("ErrTable already " & _ "exists. Do you want to delete and " & _ "rebuild all rows?", vbQuestion + vbYesNo) 14 If intMsgRtn = vbYes Then ' Reply was YES-delete rows and rebuild ' Run quick SQL to delete rows 15 dbMyDatabase.Execute_ "DELETE * FROM ErrTable;", dbFailOnError 16 Else ' Reply was NO-done 17 rcdErrRecSet.Close ' Close the table 18 Exit Function ' And exit 19 End If 20 Case 3011, 3078 ' Couldn't find table, ' so build it 21 On Error GoTo 0 ' Turn off error trapping ' Create a new table to contain error rows 22 Set tblErrTable = _ dbMyDatabase.CreateTableDef("ErrTable") ' Create a field in ErrTable to contain the ' error code 23 Set fldMyField = tblErrTable.CreateField( _ "ErrorCode", DB_LONG) ' Append "ErrorCode" field to the fields ' collection in the new table definition 24 tblErrTable.Fields.Append fldMyField ' Create a field in ErrTable for the error ' description 25 Set fldMyField = _ tblErrTable.CreateField("ErrorString", _ DB_MEMO) ' Append "ErrorString" field to the fields ' collection in the new table definition 26 tblErrTable.Fields.Append fldMyField ' Append the new table to the TableDefs ' collection in the current database 27 dbMyDatabase.TableDefs.Append tblErrTable ' Set text field width to 5" (7200 twips) ' (calls sub procedure) 28 SetFieldProperty _ tblErrTable![ErrorString], _ "ColumnWidth", DB_INTEGER, 7200 ' Create a Primary Key 29 Set idxPKey = tblErrTable.CreateIndex("PrimaryKey") ' Create and append the field to the index fields collection 30 idxPKey.Fields.Append idxPKey.CreateField("ErrorCode") ' Make it the Primary Key idxPKey.Primary = True ' Create the index 31 tblErrTable.Indexes.Append idxPKey ' Set recordset to Errors Table recordset 32 Set rcdErrRecSet = _ dbMyDatabase.OpenRecordset("ErrTable") 33 Case Else ' Can't identify the error-write message ' and bail out 34 MsgBox "Unknown error in CreateErrTable " & _ Err & ", " & Error$(Err), 16 35 Exit Function 36 End Select ' Initialize progress meter on the status bar 37 varReturnVal = SysCmd(acSysCmdInitMeter, _ "Building Error Table", 32767) ' Turn on hourglass to show this might take ' a while 38 DoCmd.Hourglass True ' Start a transaction to make it go fast 39 ws.BeginTrans ' Loop through Microsoft Access error codes, ' skipping codes that generate ' "Application-defined or object-define error" ' message 40 For lngErrCode = 1 To 32767 41 varErrString = AccessError(lngErrCode) If IsNothing(varErrString) Or _ ' If AccessError returned nothing, then try Error varErrString = "Application-defined or object-defined error" Then varErrString = Error(lngErrCode) End If 42 If Not IsNothing(varErrString) Then 43 If varErrString <> "Application-" & _ "defined or object-defined error" Then ' Add each error code and string to ' Errors table 44 rcdErrRecSet.AddNew 45 rcdErrRecSet("ErrorCode") = lngErrCode 46 rcdErrRecSet("ErrorString") = varErrString 47 rcdErrRecSet.Update 48 End If 49 End If ' Update the status meter 50 varReturnVal = SysCmd(acSysCmdUpdateMeter, _ lngErrCode) ' Process next error code 51 Next lngErrCode 52 ws.CommitTrans ' Close recordset 53 rcdErrRecSet.Close ' Turn off the hourglass-you're done 54 DoCmd.Hourglass False ' And reset the status bar 55 varReturnVal = SysCmd(acSysCmdClearStatus) ' Select new table in the Navigation Pane ' to refresh the list 56 DoCmd.SelectObject acTable, "ErrTable", True ' Open a confirmation dialog box 57 MsgBox "Errors table created." 58 End Function
Table 19–6 lists the statement line numbers and explains the code on each line in the preceding Visual Basic code example.
Line | Explanation |
---|---|
1 | Declare the beginning of the function. The function has no arguments. |
2 | You can begin a comment anywhere on a statement line by preceding the comment with a single quotation mark. You can also create a comment statement using the Rem statement. |
3 | Declare local variables for a Database object, a TableDef object, a Field object, and an Index object. |
4 | Declare local variables for a Recordset object, a Long Integer, and an Integer. |
5 | Declare local variables for a Variant that is used to accept the return value from the SysCmd function, a Variant that is used to accept the error string returned by the AccessError function, and a Workspace object. |
6 | Initialize the Database object variable by setting it to the current database. |
7 | Initialize the Workspace object by setting it to the current workspace. |
8 | Enable error trapping but execute the next statement if an error occurs. |
9 | Initialize the Recordset object variable by attempting to open the ErrTable table. If the table does not exist, this generates an error. |
10 | Call the Err function to see whether an error occurred. The following Case statements check the particular error values that interest you. |
11 | The first Case statement tests for an Err value of 0, indicating no error occurred. If no error occurred, the table already existed and opened successfully. |
12 | Turn off error trapping because you don’t expect any more errors. |
13 | Use the MsgBox function to ask whether you want to clear and rebuild all rows in the existing table. The vbQuestion intrinsic constant asks MsgBox to display the question icon, and the vbYesNo intrinsic constant requests Yes and No buttons (instead of the default OK button). The statement assigns the value returned by MsgBox so that you can test it on the next line. |
14 | If you click Yes, MsgBox returns the value of the intrinsic constant vbYes. (vbYes happens to be the integer value 6, but the constant name is easier to remember than the number.) |
15 | Run a simple SQL statement to delete all the rows in the error table. |
16 | Else clause that goes with the If statement on line 14. |
17 | Close the table if the table exists and you clicked the No button on line 13. |
18 | Exit the function. |
19 | End If statement that goes with the If statement on line 14. |
20 | Second Case statement. Error codes 3011 and 3078 are both “object not found.” |
21 | Turn off error trapping because you don’t expect any more errors. |
22 | Use the CreateTableDef method on the database to start a new table definition. This is the same as clicking the Table Design button in the Tables group on the Create tab of the Ribbon. |
23 | Use the CreateField method on the new table to create the first field object-a long integer (the intrinsic constant DB_LONG) named ErrorCode. |
24 | Append the first new field to the Fields collection of the new Table object. |
25 | Use the CreateField method to create the second field-a memo field named ErrorString. |
26 | Append the second new field to the Fields collection of the new Table object. |
27 | Save the new table definition by appending it to the TableDefs collection of the Database object. If you were to halt the code at this point and repaint the Navigation Pane, you would find the new ErrTable listed. |
28 | Call the SetFieldProperty subroutine in this module to set the column width of the ErrorString field to 7200 twips (5 inches). This ensures that you can see more of the error text when you open the table in Datasheet view. |
29 | Use the CreateIndex method of the TableDef to begin building an index. |
30 | Create a single field and append it to the Fields collection of the index. The following statement sets the Primary property of the index to True to indicate that this will be the primary key. |
31 | Save the new primary key index by appending it to the Indexes collection of the TableDef. |
32 | Open a recordset by using the OpenRecordset method on the table. |
33 | This Case statement traps all other errors. |
34 | Show a message box with the error number and the error message. |
35 | Exit the function after an unknown error. |
36 | End Select statement that completes the Select Case statement on line 10. |
37 | Call the SysCmd function to place a “building table” message on the status bar, and initialize a progress meter. The CreateErrTable function will look at 32,767 different error codes. |
38 | Turn the mouse pointer into an hourglass to indicate that this procedure will take a few seconds. |
39 | Use the BeginTrans method of the Workspace object to start a transaction. Statements within a transaction are treated as a single unit. Changes to data are saved only if the transaction completes successfully with a CommitTrans method. Using transactions when you’re updating records can speed performance by reducing disk access. |
40 | Start a For loop to check each error code from 1 through 32,767. |
41 | Assign the error text returned by the AccessError function to the variable varErrString. If the string is empty or returned “Application-defined or objectdefined error,” try calling the Error function to get the text of the message. |
42 | Call the IsNothing function in the modUtility module of the sample database to test whether the text returned is blank. You don’t want blank rows, so don’t add a row if the AccessError function for the current error code returns a blank string. |
43 | Lots of error codes are defined as “Application-defined or object-defined error.” You don’t want any of these, so this statement adds a row only if the AccessError function for the current error code doesn’t return this string. |
44 | Use the AddNew method to start a new row in the table. |
45 | Set the ErrorCode field equal to the current error code. |
46 | Save the text of the message in the ErrorString field. Because we defined the field as a memo, we don’t need to worry about the length of the text. |
47 | Use the Update method to save the new row. |
48 | End If statement that completes the If statement on line 43. |
49 | End If statement that completes the If statement on line 42. |
50 | After handling each error code, update the progress meter on the status bar to show how far you’ve gotten. |
51 | Next statement that completes the For loop begun on line 40. Visual Basic increments lngErrCode by 1) and executes the For loop again until lngErrCode is greater than 32,767. |
52 | CommitTrans method that completes the transaction begun on line 39. |
53 | After looping through all possible error codes, close the recordset. |
54 | Change the mouse pointer back to normal. |
55 | Clear the status bar. |
56 | Put the focus on the ErrTable table in the Navigation Pane. |
57 | Display a message box confirming that the function has completed. |
58 | End of the function. |
You should now have a basic understanding of how to create functions and subroutines using Visual Basic. In the next chapter, you’ll enhance what you’ve learned as you study major parts of the Conrad Systems Contacts, Housing Reservations, and Wedding List applications.