THEO TODMAN’S WEBSITE CODE PAGES


This Page provides a jumping-off point for the VBA Code that generates my Website.

Table of Code Documentation Location 43 (10 items)

Core_URL_GenFunctor_05Prune_Raw_LinksReference_Files
Remove_HyperlinksTrimBranchesZap_Cross_ReferencesMonthly_Report_Note1024_Output
PapersToNotes_PrelimsPianola_Check..

To access information, click on one of the links in the table above.

Go to top of page



Source Code of: Core_URL_Gen
Procedure Type: Public Function
Module: Spider
Lines of Code: 43
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Core_URL_Gen(In_URL)
0002Dim In_URL_Local As String
0003Dim URL_Segment As String
0004Dim srtReturned As String
0005Dim i As Integer
0006Dim j As Integer
0007Dim k As Integer
0008Dim Numeric_Segment As Boolean
0009In_URL_Local = In_URL
0010i = 1
0011srtReturned = ""
0012j = InStr(i, In_URL_Local, ".")
0013URL_Segment = ""
0014Do While j > 0 Or URL_Segment <> ""
0015 If j > 0 Then
0016 URL_Segment = Mid(In_URL_Local, i, j - i)
0017 End If
0018 Numeric_Segment = False
0019 For k = 1 To Len(URL_Segment)
0020 If Mid(URL_Segment, k, 1) >= 0 And Mid(URL_Segment, k, 1) <= 9 Then
0021 Numeric_Segment = True
0022 k = Len(URL_Segment) + 1
0023 End If
0024 Next k
0025 If Numeric_Segment = False Then
0026 If srtReturned <> "" Then
0027 srtReturned = srtReturned & "."
0028 End If
0029 srtReturned = srtReturned & URL_Segment
0030 End If
0031 If j > 0 Then
0032 i = j + 1
0033 j = InStr(i, In_URL_Local, ".")
0034 If j = 0 Then
0035 URL_Segment = Mid(In_URL_Local, i, Len(In_URL_Local))
0036 End If
0037 Else
0038 URL_Segment = ""
0039 End If
0040Loop
0041'Debug.Print Now(); "- URL: " & In_URL_Local; " Returned: " & srtReturned
0042Core_URL_Gen = srtReturned
0043End Function

Procedures Calling This Procedure (Core_URL_Gen) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page


Source Code of: Functor_05
Procedure Type: Public Function
Module: Functors
Lines of Code: 70
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor_05(strQuery, strNote_Text)
0002'Development Log report - Completed Items - Category Sequence
0003Dim rs As Recordset
0004Dim strNote_Text_Local
0005Dim Implementation_Period As String
0006Dim Category As String
0007Dim Development As String
0008Dim Category_Saved As String
0009Dim strCategory_Text As String
0010Dim Implementation_Period_Saved As String
0011Dim strImplementation_Period_Text As String
0012strNote_Text_Local = ""
0013Category_Saved = "ZZZZZ"
0014strCategory_Text = ""
0015Implementation_Period_Saved = "ZZZZ"
0016strImplementation_Period_Text = ""
0017Set rs = CurrentDb.OpenRecordset(strQuery)
0018If Not rs.EOF Then
0019 rs.MoveFirst
0020 Functor_05 = "Yes"
0021Else
0022 Functor_05 = "No"
0023 Exit Function
0024End If
0025Do Until rs.EOF
0026 Category = rs.Fields(0) & ""
0027 Implementation_Period = rs.Fields(1)
0028 Development = rs.Fields(2) & ""
0029 If (Implementation_Period <> Implementation_Period_Saved) Or (Category <> Category_Saved) Then
0030 If Implementation_Period_Saved <> "ZZZZ" Then
0031 'Finalise Previous Implementation Period
0032 strImplementation_Period_Text = "|##|" & strImplementation_Period_Text & "|##|"
0033 strImplementation_Period_Text = "|1|<b>" & Implementation_Period_Saved & "</b>" & strImplementation_Period_Text
0034 End If
0035 'Ready for next Period
0036 If Category = Category_Saved Then
0037 strCategory_Text = strCategory_Text & strImplementation_Period_Text
0038 strImplementation_Period_Text = ""
0039 End If
0040 End If
0041 If Category <> Category_Saved Then
0042 If Category_Saved <> "ZZZZZ" Then
0043 'Finalise Previous Priority
0044 strCategory_Text = "|ii|" & strCategory_Text & strImplementation_Period_Text & "|ii|"
0045 strCategory_Text = "|.|<b>" & Category_Saved & "</b>" & strCategory_Text
0046 End If
0047 'Ready for next Period
0048 strNote_Text_Local = strNote_Text_Local & strCategory_Text
0049 strCategory_Text = ""
0050 Implementation_Period_Saved = "ZZZZ"
0051 strImplementation_Period_Text = ""
0052 End If
0053 strImplementation_Period_Text = strImplementation_Period_Text & "|.|" & Development
0054 'Move on ...
0055 Category_Saved = Category
0056 Implementation_Period_Saved = Implementation_Period
0057 rs.MoveNext
0058Loop
0059'Finish the list ...
0060strImplementation_Period_Text = "|##|" & strImplementation_Period_Text & "|##|"
0061strImplementation_Period_Text = "|1|<b>" & Implementation_Period_Saved & "</b>" & strImplementation_Period_Text
0062strCategory_Text = "|ii|" & strCategory_Text & strImplementation_Period_Text & "|ii|"
0063strCategory_Text = "|.|<b>" & Category_Saved & "</b>" & strCategory_Text
0064strNote_Text_Local = strNote_Text_Local & strCategory_Text
0065'Top and Tail
0066strNote_Text_Local = "<b><u>Completed Items By Category</u>:-</b> |..|" & strNote_Text_Local & "|..|"
0067'Tidy up
0068Set rs = Nothing
0069strNote_Text = strNote_Text_Local
0070End Function

Procedures Calling This Procedure (Functor_05) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page


Source Code of: Monthly_Report_Note1024_Output
Procedure Type: Public Sub
Module: Monthly Reporting
Lines of Code: 26
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Monthly_Report_Note1024_Output()
0002Dim strLine As String
0003Dim rsTableControl As Recordset
0004Dim strQuery As String
0005'Read Note 1024 for update
0006 strQuery = "SELECT Notes.* FROM Notes WHERE Notes.ID = 1024;"
0007Set rsTableControl = CurrentDb.OpenRecordset(strQuery)
0008rsTableControl.MoveFirst
0009rsTableControl.Edit
0010'Update Note 1024 Title
0011strLine = "Status: Thesis Dashboard (" & StrTitle_Year & ": " & StrTitle_Month & ")"
0012rsTableControl.Fields(1) = strLine
0013'Set Note Status
0014rsTableControl.Fields(10) = "Temp"
0015rsTableControl.Update
0016'Output the Note regeneration request
0017 DoCmd.RunSQL ("DELETE Notes_To_Regen.* FROM Notes_To_Regen;")
0018 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Notes_To_Regen.* FROM Notes_To_Regen;")
0019rsTableControl.AddNew
0020rsTableControl.Fields(0) = 1024
0021rsTableControl.Update
0022Archive_Notes_Now = "No"
0023Regenerate_the_Links = "No"
0024Regen_Notes_Only = "Yes"
0025 CreateNotesWebPages
0026End Sub

Procedures Calling This Procedure (Monthly_Report_Note1024_Output) Procedures Called By This Procedure (Monthly_Report_Note1024_Output) Tables / Queries / Fragments Directly Used By This Procedure (Monthly_Report_Note1024_Output) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page


Source Code of: PapersToNotes_Prelims
Procedure Type: Public Sub
Module: Testing
Lines of Code: 10

Line-No. / Ref.Code Line
0001Public Sub PapersToNotes_Prelims()
0002Dim strQuery As String
0003 strQuery = "DELETE * FROM Cross_Reference_Prelims;"
0004DoCmd.RunSQL (strQuery)
0005 strQuery = "PapersToNotes_Prelims_GEN"
0006DoCmd.OpenQuery (strQuery)
0007'Delete rows associated with Note 874 (Auto-Xref Test Note)
0008 strQuery = "DELETE * FROM Cross_Reference_Prelims WHERE Calling_ID = 874 AND Calling_Type = ""N"";"
0009DoCmd.RunSQL (strQuery)
0010End Sub

Procedures Calling This Procedure (PapersToNotes_Prelims) Tables / Queries / Fragments Directly Used By This Procedure (PapersToNotes_Prelims) Go To Top of This Page
Link to VBA Code Control Page


Source Code of: Pianola_Check
Procedure Type: Public Sub
Module: Testing
Lines of Code: 151
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Pianola_Check()
0002Dim ie As InternetExplorer
0003Dim html
0004Dim i As Long
0005Dim j As Long
0006Dim k As Long
0007Dim Requested_URL
0008Dim Returned_URL
0009Dim start As Date
0010Dim RunTime As Single
0011Dim Running_Hours As Single
0012Dim Issue As String
0013Dim Defunct As Boolean
0014Dim Update_Time As Double
0015Dim Recent_Check As Date
0016Dim Recent_Check_OK As Boolean
0017Dim Last_Bounce As Date
0018Dim Given_Up As Boolean
0019Dim Uncheckable As Boolean
0020Dim strDocument As String
0021Dim Pianola_ID As Long
0022Dim Max_Pianola As Long
0023Dim Pianola_Root As String
0024Dim strDate As String
0025Max_Pianola = 100
0026Pianola_ID = 2
0027Pianola_Root = "https://app.pianola.net/Results/Session"
0028'Fix the parameters below ...
0029Stop
0030Recent_Check = Now() - 10 'Parameter - Check gap in days
0031RunTime = 5 'Parameter - run time in hours
0032'Open Internet Explorer in memory, and go to website
0033Set ie = New InternetExplorer
0034ie.Visible = False
0035start = Now()
0036Last_Bounce = start
0037Do While Pianola_ID < Max_Pianola
0038 'Bounce IE every 5 minutes
0039 If (Now() - Last_Bounce) * 24 * 60 > 5 Then
0040 ie.Quit
0041 Set ie = Nothing
0042 Set ie = New InternetExplorer
0043 ie.Visible = False
0044 Last_Bounce = Now()
0045 Debug.Print Now() & " - "; "IE Bounced at " & Last_Bounce
0046 End If
0047 Uncheckable = False
0048 Update_Time = Now()
0049 Given_Up = False
0050 Recent_Check_OK = True
0051 If Recent_Check_OK = True Then
0052 Requested_URL = Pianola_Root & Pianola_ID
0053 Defunct = False
0054 Issue = ""
0055 On Error GoTo Err_Fix
0056Resume_Here:
0057 ie.Navigate Requested_URL
0058 Update_Time = Now()
0059 'Wait until IE is done loading page
0060 i = 1
0061 Do While ie.ReadyState <> READYSTATE_COMPLETE
0062 DoEvents
0063 i = i + 1
0064 If i > 3000 Then
0065 Given_Up = True
0066 GoTo Give_Up
0067 End If
0068 Loop
0069Give_Up:
0070 If Given_Up = False Then
0071 Returned_URL = ie.LocationURL
0072 strDocument = ie.Document
0073 If strDocument = "[object HTMLDocument]" Then
0074 strDocument = ie.Document.DocumentElement.innerHtml
0075 Else
0076 strDocument = ie.Document.DocumentElement.innerHtml
0077 End If
0078 If Requested_URL <> Returned_URL Then
0079 If Replace(Returned_URL, "https", "http") = Requested_URL Then
0080 Debug.Print Now() & " - "; "URL Secured: "; Returned_URL
0081 Issue = "URL Secured"
0082 Else
0083 If (Requested_URL & "/" = Returned_URL) Or (Requested_URL = Returned_URL & "/") Then
0084 Debug.Print Now() & " - "; "URL with trailing slash: "; Returned_URL
0085 Issue = "URL with trailing slash"
0086 Else
0087 If Left(Returned_URL, Len("http://www.webaddresshelp.bt.com")) = "http://www.webaddresshelp.bt.com" Then
0088 Debug.Print Now() & " - "; "URL Not found"
0089 Issue = "URL Not found"
0090 Defunct = True
0091 Else
0092 If Left(Returned_URL, Len("http://web.demo.barefruit.co.uk/")) = "http://web.demo.barefruit.co.uk/" Then
0093 Debug.Print Now() & " - "; "Website reports Document Not Found"
0094 Issue = "Document Not Found"
0095 Else
0096 Debug.Print Now() & " - "; "URL Differs: "; Returned_URL
0097 Issue = "URL Differs"
0098 End If
0099 End If
0100 End If
0101 End If
0102 End If
0103 i = InStr(strDocument, "<title>")
0104 If i > 0 Then
0105 j = InStr(i, strDocument, "</title>")
0106 If j > 0 Then
0107 k = InStr(i, strDocument, ",")
0108 End If
0109 If k > 0 And k < j Then
0110 strDate = Trim(Mid(strDocument, k + 1, j - k - 1))
0111 Debug.Print Now() & " - "; Pianola_ID, strDate
0112 End If
0113 End If
0114 i = InStr(strDocument, "<a href=""/Results/PublicView/")
0115 k = Len("<a href=""/Results/PublicView/")
0116 If i > 0 Then
0117 j = InStr(i + k, strDocument, """>")
0118 If j > 0 Then
0119 strDate = Trim(Mid(strDocument, i + k, j - i - k))
0120 Debug.Print Now() & " - "; Pianola_ID, strDate
0121 End If
0122 End If
0123 End If
0124 End If
0125 If Given_Up = True Then
0126 'Flag those with file-types that can't be checked
0127 End If
0128 Running_Hours = (Now() - start) * 24
0129 If Running_Hours > RunTime Then
0130 Stop
0131 start = Now()
0132 End If
0133 Pianola_ID = Pianola_ID + 1
0134Loop
0135ie.Quit
0136Set ie = Nothing
0137Debug.Print Now() & " - "; "Job complete at " & Now()
0138MsgBox "Webrefs Checker Completed at " & Now()
0139Exit Sub
0140Err_Fix:
0141Debug.Print Now() & " - "; Err.Description
0142DoEvents
0143Err.Clear
0144ie.Quit
0145Set ie = Nothing
0146Set ie = New InternetExplorer
0147ie.Visible = False
0148Last_Bounce = Now()
0149Debug.Print Now() & " - "; "IE Bounced at " & Last_Bounce
0150GoTo Resume_Here
0151End Sub

Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page


Source Code of: Prune_Raw_Links
Procedure Type: Public Function
Module: Spider
Lines of Code: 24
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Prune_Raw_Links(strDirectory, strFile)
0002Dim rsRawLinks As Recordset
0003Dim strQuery As String
0004Dim i As Integer
0005Dim strMessage As String
0006 strQuery = "SELECT Raw_Links.* FROM Raw_Links WHERE (((Raw_Links.Directory)=""" & strDirectory & """) AND ((Raw_Links.File_Name)=""" & strFile & """));"
0007Set rsRawLinks = CurrentDb.OpenRecordset(strQuery)
0008If Not rsRawLinks.EOF Then
0009 rsRawLinks.MoveFirst
0010 i = 0
0011 Do Until rsRawLinks.EOF
0012 rsRawLinks.Delete
0013 i = i + 1
0014 rsRawLinks.MoveNext
0015 Loop
0016 strMessage = i & " Raw_Links deleted."
0017Else
0018 strMessage = "No Raw_Links to delete."
0019End If
0020 OK = Check_Database_Size()
0021 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0022Debug.Print Now() & " - Prune_Raw_Links: File = " & strDirectory & strFile & ". " & strMessage
0023Set rsRawLinks = Nothing
0024End Function

Procedures Calling This Procedure (Prune_Raw_Links) Procedures Called By This Procedure (Prune_Raw_Links) Tables / Queries / Fragments Directly Used By This Procedure (Prune_Raw_Links) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page


Source Code of: Reference_Files
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 91
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Reference_Files(strText, Calling_Type, Calling_ID, Calling_Timestamp, Optional Depth)
0002Dim x As Long
0003Dim Y As Long
0004Dim strFile_Name As String
0005Dim FileRef As Long
0006Dim strText_Local As String
0007Dim strText_End As String
0008Dim qryString As String
0009Dim rsTableToRead As Recordset
0010Dim iDepth As Integer
0011Dim strPrefix As String
0012Dim i As Integer
0013If Len(strText) = 0 Then
0014 Reference_Files = "Not Found"
0015 Exit Function
0016End If
0017If IsMissing(Depth) Then
0018 iDepth = 2
0019Else
0020 iDepth = Depth
0021End If
0022i = 0
0023strPrefix = ""
0024Do While i < iDepth
0025 strPrefix = strPrefix & "../"
0026 i = i + 1
0027Loop
0028strText_Local = strText
0029x = 1
0030x = InStr(x, strText_Local, "+F")
0031Reference_Files = "Not Found"
0032Do While x > 0
0033 Reference_Files = "Found"
0034 Y = InStr(x + 1, strText_Local, "F+")
0035 'Watch out for false positives in finding +F
0036 If Y = 0 Or x = 1 Then 'x = 1 is a fudge for the next test ...
0037 x = x + 1
0038 Else
0039 If Mid(strText_Local, x - 1, 4) = "++FN" Then 'Watch out for footnotes!
0040 x = x + 1
0041 Else
0042 If (Y - x > 80) Or (Y - x = 2) Then 'Need to decide on a sensible limit!
0043 x = x + 1
0044 Else
0045 strFile_Name = Mid(strText_Local, x + 2, Y - x - 2)
0046 If Y > Len(strText_Local) - 2 Then
0047 strText_End = ""
0048 Else
0049 strText_End = Mid(strText_Local, Y + 2, Len(strText_Local))
0050 End If
0051 'Determine File_ID (or add if new)
0052 qryString = "SELECT * FROM PDF_File_Control WHERE (((PDF_File_Control.File_Name)=""" & strFile_Name & """));"
0053 Set rsTableToRead = CurrentDb.OpenRecordset(qryString)
0054 If Not rsTableToRead.EOF Then
0055 rsTableToRead.MoveFirst
0056 FileRef = rsTableToRead.Fields(0)
0057 Else
0058 'Insert a new row
0059 'Check no spaces in file name ...
0060 If InStr(strFile_Name, " ") > 0 Then
0061 Debug.Print Now() & " - Reference_Files: " & strFile_Name & " contains spaces." 'Bug
0062 End If
0063 rsTableToRead.AddNew
0064 rsTableToRead.Fields(1) = strFile_Name
0065 rsTableToRead.Fields(2) = Now()
0066 rsTableToRead.Fields(3) = Calling_ID
0067 rsTableToRead.Update
0068 'Read it back to get the ID
0069 qryString = "SELECT * FROM PDF_File_Control WHERE (((PDF_File_Control.File_Name)=""" & strFile_Name & """));"
0070 Set rsTableToRead = CurrentDb.OpenRecordset(qryString)
0071 If rsTableToRead.EOF Then
0072 Debug.Print Now() & " - Reference_Files: " & strFile_Name & " not found." 'Bug
0073 Else
0074 rsTableToRead.MoveFirst
0075 FileRef = rsTableToRead.Fields(0)
0076 End If
0077 End If
0078 'strText_Local = Left(strText_Local, x - 1) & IIf(Calling_Type <> "X", "<a name=""" & NameRef + 1 & """></a>", "") & "[PDF File]++1319#" & strFile_Name & "++" & strText_End
0079 strText_Local = Left(strText_Local, x - 1) & "[PDF File]++1319#" & strFile_Name & "++" & strText_End
0080 If Calling_Type <> "X" Then
0081 'NameRef = NameRef + 1
0082 OK = Cross_Reference_Add(Calling_Type, Calling_ID, Calling_Timestamp, "F", FileRef, 0)
0083 End If
0084 Set rsTableToRead = Nothing
0085 End If
0086 End If
0087 End If
0088 x = InStr(x, strText_Local, "+F")
0089Loop
0090strText = strText_Local
0091End Function

Procedures Calling This Procedure (Reference_Files) Procedures Called By This Procedure (Reference_Files) Tables / Queries / Fragments Directly Used By This Procedure (Reference_Files) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page


Source Code of: Remove_Hyperlinks
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 37
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Remove_Hyperlinks(Photo_Title)
0002Dim Hyperlink_Start As Integer
0003Dim Hyperlink_End As Integer
0004Dim Photo_Title_Local
0005Dim Hyperlink As String
0006Photo_Title_Local = Photo_Title
0007'Remove hard-codings ...
0008Hyperlink_Start = 1
0009Do While Hyperlink_Start > 0
0010 Hyperlink_Start = InStr(Hyperlink_Start, Photo_Title_Local, "<a href")
0011 If Hyperlink_Start > 0 Then
0012 Hyperlink_End = InStr(Hyperlink_Start, Photo_Title_Local, ">")
0013 Photo_Title_Local = Left(Photo_Title_Local, Hyperlink_Start - 1) & Mid(Photo_Title_Local, Hyperlink_End + 1)
0014 End If
0015Loop
0016Photo_Title_Local = Replace(Photo_Title_Local, "</a>", "")
0017'Remove Note-links
0018Hyperlink_Start = 1
0019Do While Hyperlink_Start > 0
0020 Hyperlink_Start = InStr(Hyperlink_Start, Photo_Title_Local, "++")
0021 If Hyperlink_Start > 0 Then
0022 Hyperlink_End = InStr(Hyperlink_Start + 1, Photo_Title_Local, "++")
0023 If Hyperlink_End > 0 Then
0024 Hyperlink = Mid(Photo_Title_Local, Hyperlink_Start, Hyperlink_End - Hyperlink_Start + 2)
0025 If Len(Hyperlink) < 20 Then
0026 Photo_Title_Local = Left(Photo_Title_Local, Hyperlink_Start - 1) & Mid(Photo_Title_Local, Hyperlink_Start + Len(Hyperlink))
0027 Else
0028 Hyperlink_Start = Hyperlink_Start + 20
0029 End If
0030 Else
0031 Hyperlink_Start = 0
0032 End If
0033 End If
0034Loop
0035'Return
0036Remove_Hyperlinks = Photo_Title_Local
0037End Function

Procedures Calling This Procedure (Remove_Hyperlinks) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page


Source Code of: TrimBranches
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 18

Line-No. / Ref.Code Line
0001Public Function TrimBranches(strText)
0002Dim x As Long
0003Dim Y As Long
0004Dim strText_Local As String
0005If Len(strText) = 0 Then
0006 TrimBranches = "Not Found"
0007 Exit Function
0008End If
0009strText_Local = strText
0010Y = 0
0011x = 1
0012Do Until x = Y
0013 x = Len(strText)
0014 strText_Local = Replace(strText_Local, "<BR><BR><BR>", "<BR><BR>")
0015 Y = Len(strText)
0016Loop
0017strText = strText_Local
0018End Function

Procedures Calling This Procedure (TrimBranches) Go To Top of This Page
Link to VBA Code Control Page


Source Code of: Zap_Cross_References
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 30
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Zap_Cross_References(Calling_Type, Calling_ID, Calling_Timestamp)
0002'This function does two things: (a) deletes the references associated with a calling object (b) saves these references in the zapper table so they can be compared with the replacement rows and appropriate action taken
0003Dim strQuery As String
0004Dim Calling_ID_Local As Integer
0005Dim rsAuthors As Recordset
0006'Zap the Zapper
0007 strQuery = "DELETE * FROM Cross_Reference_Zapper;"
0008DoCmd.RunSQL (strQuery)
0009'Find the Calling_ID for Authors
0010If Calling_Type = "A" Then
0011 strQuery = "SELECT Authors.Author_ID FROM Authors WHERE Authors.Author_Name=""" & Calling_ID & """;"
0012 Set rsAuthors = CurrentDb.OpenRecordset(strQuery)
0013 If Not rsAuthors.EOF Then
0014 Calling_ID_Local = rsAuthors.Fields(0)
0015 Else
0016 Calling_ID_Local = 0
0017 End If
0018 Set rsAuthors = Nothing
0019Else
0020 Calling_ID_Local = Calling_ID
0021End If
0022If Calling_ID_Local <> 0 Then
0023 'Populate the Zapper
0024 strQuery = "INSERT INTO Cross_Reference_Zapper SELECT Cross_Reference.* FROM Cross_Reference WHERE (((Cross_Reference.Calling_Type)=""" & Calling_Type & """) AND ((Cross_Reference.Calling_ID)=" & Calling_ID_Local & ") AND ((Cross_Reference.Calling_Timestamp)=" & Calling_Timestamp & "));"
0025 DoCmd.RunSQL (strQuery)
0026 'Do the Zapping
0027 strQuery = "DELETE Cross_Reference.* FROM Cross_Reference INNER JOIN [Cross_Reference_Zapper] ON Cross_Reference.ID = [Cross_Reference_Zapper].ID;"
0028 DoCmd.RunSQL (strQuery)
0029End If
0030End Function

Procedures Calling This Procedure (Zap_Cross_References) Tables / Queries / Fragments Directly Used By This Procedure (Zap_Cross_References) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page


© Theo Todman, June 2007 - May 2025. Please address any comments on this page to theo@theotodman.com. File output:
Website Maintenance Dashboard
Return to Top of this Page Return to Theo Todman's Philosophy Page Return to Theo Todman's Home Page