Sub btnSelect_Click()
Sub btnSelect_Click ()
'This button takes records from the manually imported
'membership database file and places them into the
'table SINDSORT. In SINDSORT, there is no key field,
'so records can be sorted here, and key field labels
'manufactured. After the key field labels are made,
'which are also used for help topic names, the contents
'of SINDSORT is poured into SINDIVID, the final table
'where help search words are manufactured, and browse
'numbers generated.
Const QU = """"
Dim UtilStrg0 As String
Dim UtilStrg1 As String
Dim NextLine As String
Dim NumText As String
Dim KeyAlpha As String
Dim UtilIntg0 As Integer
Dim UtilIntg1 As Integer
Dim StringSize As Integer
Dim CharNumber As Integer
Dim ProgShow As Integer
Dim UtilVart0 As Variant
Dim DogDB As Database
Dim DogSet As Recordset
On Error GoTo Err_btnSelect_Click
UtilVart0 = Null
NextLine = Chr$(13) & Chr$(10)
UtilVart0 = Forms![frmHelpPrep]![lstTableNames]
If IsNull(UtilVart0) Then
MsgBox "To begin, select the newly imported table from the list box to the left."
GoTo Exit_btnSelect_Click
End If
'Inform user what is about to happen, and give option for exiting.
UtilStrg0 = "First, table SINDSORT, a utility table for sorting, will be emptied."
UtilStrg0 = UtilStrg0 & NextLine & NextLine
UtilStrg0 = UtilStrg0 & "Then table " & QU & UtilVart0 & QU & " will be moved into table SINDSORT."
UtilStrg0 = UtilStrg0 & NextLine & NextLine & "Finally, sorting will take place in order to "
UtilStrg0 = UtilStrg0 & "make key identifiers and topic names for each person."
UtilStrg0 = UtilStrg0 & NextLine & NextLine & "CONTINUE?"
UtilIntg0 = MsgBox(UtilStrg0, 4)
If UtilIntg0 = 7 Then
GoTo Exit_btnSelect_Click
End If
'Now ensure all records are removed from table SINDSORT.
UtilStrg0 = "DELETE * FROM SINDSORT"
DoCmd RunSQL (UtilStrg0)
'Now move records into the SINDSORT table.
UtilStrg0 = "INSERT INTO SINDSORT ( Lastname, Firstname, Middname, PriCompany, Company, PriAddress, PriCity, PriState, PriZip, PhoneAll, [E-mail], MemGrade ) "
UtilStrg0 = UtilStrg0 & "SELECT DISTINCTROW MEMCOM.LAST, MEMCOM.FIRST, MEMCOM.MIDD, MEMCOM.CO1, MEMCOM.CO2, MEMCOM.STREET, MEMCOM.CITY, MEMCOM.ST, MEMCOM.ZIP, MEMCOM.PHONE, MEMCOM.EMAIL, MEMCOM.GRADE "
UtilStrg0 = UtilStrg0 & "FROM MEMCOM "
UtilStrg0 = UtilStrg0 & "ORDER BY MEMCOM.LAST, MEMCOM.FIRST, MEMCOM.MIDD, MEMCOM.CO2;"
DoCmd RunSQL (UtilStrg0)
Dogbert:
'Now analyze each record to build a unique key identifier
'that will also be used as a unique Help Topic string.
UtilStrg0 = "SELECT * FROM SINDSORT"
Set DogDB = DBEngine.Workspaces(0).Databases(0)
Set DogSet = DogDB.OpenRecordset(UtilStrg0)
'Initiate progress meter.
DogSet.MoveLast
ProgShow = DogSet.RecordCount
UtilVart0 = SysCmd(SYSCMD_INITMETER, "Preparing topic names and key record IDs in SINDSORT...", ProgShow)
DoCmd Hourglass True
'Take care of first record.
DogSet.MoveFirst
UtilStrg0 = DogSet![Lastname]
'Process the last name characters so that only alphabet
'letters are present. Non-alphabet characters, such as
'an apostrophe or dash, are eliminated.
StringSize = Len(UtilStrg0)
KeyAlpha = ""
For UtilIntg1 = 1 To StringSize
NumText = Mid(UtilStrg0, UtilIntg1, 1)
CharNumber = Asc(NumText)
If (CharNumber > 64 And CharNumber < 91) Or (CharNumber > 96 And CharNumber < 123) Then
KeyAlpha = KeyAlpha & NumText
End If
Next UtilIntg1
'Now process so that only three capital letters are present
'in front of the numeric suffix, and the three capital
'letters are preceded by a capital P or B, for person or
'business, and a period.
UtilStrg0 = KeyAlpha
UtilStrg0 = UCase$(UtilStrg0)
UtilIntg0 = Len(UtilStrg0)
If UtilIntg0 > 3 Then
UtilStrg0 = Left$(UtilStrg0, 3)
End If
If UtilIntg0 = 1 Then
UtilStrg0 = UtilStrg0 & "AA"
End If
If UtilIntg0 = 2 Then
UtilStrg0 = UtilStrg0 & "A"
End If
UtilStrg1 = "P." & UtilStrg0 & "01"
DogSet.Edit
DogSet![PersKey] = UtilStrg1
DogSet![Topic_Name] = UtilStrg1
DogSet.Update
UtilIntg0 = 1
'Go to the next record, and
'use the variables UtilStrg0 and UtilIntg0
'as the comparison standards.
DogSet.MoveNext
ProgShow = 2
'Now sequence through the rest of the records
Do Until DogSet.EOF
UtilVart0 = SysCmd(SYSCMD_UPDATEMETER, ProgShow)
UtilStrg1 = DogSet.[Lastname]
StringSize = Len(UtilStrg1)
KeyAlpha = ""
For UtilIntg1 = 1 To StringSize
NumText = Mid(UtilStrg1, UtilIntg1, 1)
CharNumber = Asc(NumText)
If (CharNumber > 64 And CharNumber < 91) Or (CharNumber > 96 And CharNumber < 123) Then
KeyAlpha = KeyAlpha & NumText
End If
Next UtilIntg1
UtilStrg1 = KeyAlpha
UtilStrg1 = UCase$(UtilStrg1)
UtilIntg1 = Len(UtilStrg1)
If UtilIntg1 > 3 Then
UtilStrg1 = Left$(UtilStrg1, 3)
End If
If UtilIntg1 = 1 Then
UtilStrg1 = UtilStrg1 & "AA"
End If
If UtilIntg1 = 2 Then
UtilStrg1 = UtilStrg1 & "A"
End If
'Determine whether letters are same as derived from previous record.
If UtilStrg1 <> UtilStrg0 Then
UtilStrg0 = UtilStrg1
UtilIntg0 = 1
UtilStrg1 = "P." & UtilStrg1 & "01"
'If they are not, increment UtilIntg0 to make
'a unique identifier (string) one number higher.
Else
UtilIntg0 = UtilIntg0 + 1
NumText = CStr(UtilIntg0)
If UtilIntg0 < 10 Then
NumText = "0" & NumText
End If
UtilStrg1 = "P." & UtilStrg1 & NumText
End If
DogSet.Edit
DogSet![PersKey] = UtilStrg1
DogSet![Topic_Name] = UtilStrg1
DogSet.Update
DogSet.MoveNext
ProgShow = ProgShow + 1
Loop
DogSet.Close
DogDB.Close
'Announce that the topic IDs and record key IDs are done.
DoCmd Hourglass False
UtilVart0 = SysCmd(SYSCMD_REMOVEMETER)
See also: