Some Complex Visual Basic Examples


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.

A Procedure to Randomly Load Data

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.

image from book
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.

image from book
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.

Table 19–5: Explanation of Code in Example to Load Random Data
Open table as spreadsheet

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.

A Procedure to Examine All Error Codes

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.

Table 19–6: Explanation of Code in Example to Examine Error Codes
Open table as spreadsheet

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.




Microsoft Office Access 2007 Inside Out
MicrosoftВ® Office Access(TM) 2007 Inside Out (Microsoft Office Access Inside Out)
ISBN: 0735623252
EAN: 2147483647
Year: 2007
Pages: 234

Similar book on Amazon
Access 2007: The Missing Manual
Access 2007: The Missing Manual
Microsoftu00ae Office Access(TM) 2007 Step by Step (Step By Step (Microsoft))
Microsoftu00ae Office Access(TM) 2007 Step by Step (Step By Step (Microsoft))
Microsoft Office Access 2007 Forms, Reports, and Queries
Microsoft Office Access 2007 Forms, Reports, and Queries
Alison Balter's Mastering Microsoft Office Access 2007 Development
Alison Balter's Mastering Microsoft Office Access 2007 Development

flylib.com © 2008-2017.
If you may any questions please contact us: flylib@qtcs.net