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 3 (3 items)

NoteFootnotesNoteForPrintingQuery_Use_Checker.

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

Go to top of page



Source Code of: NoteFootnotes
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 164
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function NoteFootnotes(tsTextFile As TextStream, iFootNoteID, maxDepth, iDepth, Optional SuppressPrivate)
0002Dim iFootNoteID_Local As Integer
0003Dim iDepth_Local As Integer
0004Dim strLine As String
0005Dim strLineTemp As String
0006Dim rsTableControl As Recordset
0007Dim rsTableControl2 As Recordset
0008Dim rsNotesLinks As Recordset
0009Dim OK_Local As String
0010Dim FN_Blurb As String
0011Dim DatePrint As Date
0012Dim i As Integer
0013Dim This_Note_Group
0014Dim strQuery As String
0015Dim Last_Footnote_Bulletted As String
0016Dim strLine_Break As String
0017'Footnotes
0018iDepth_Local = iDepth + 1
0019 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Note_Links.Note_1_FN_ID, Note_Links.Note_2, Notes.Item_Title, Notes.Item_Text, Notes.Last_Changed, Notes.[Private?], Notes.[Title?], Notes.[Respondent?], Notes.Note_Group FROM Note_Links INNER JOIN Notes ON Note_Links.Note_2 = Notes.ID WHERE (((Note_Links.Note_1) = " & iFootNoteID & ") AND (Note_Links.Print_Note = ""Yes"") AND (Note_Links.Note_1 <> Note_Links.Note_2)) ORDER BY Note_Links.Note_1_FN_ID;")
0020If rsTableControl.EOF Then
0021Else
0022 rsTableControl.MoveFirst
0023 Do While Not rsTableControl.EOF
0024 This_Note_Group = rsTableControl.Fields(8).Value
0025 If iDepth < 1 Then
0026 iDepth_Saved = iDepth
0027 For i = 0 To 19 'Clear the Saved Array
0028 Footnote_String_Saved(i, 0) = ""
0029 Footnote_String_Saved(i, 1) = ""
0030 Next i
0031 Footnote_String = rsTableControl.Fields(0).Value
0032 Footnote_String_Saved(iDepth, 0) = Footnote_String
0033 Else
0034 If iDepth > iDepth_Saved Then
0035 iDepth_Saved = iDepth
0036 Footnote_String = Footnote_String & "." & rsTableControl.Fields(0).Value
0037 Footnote_String_Saved(iDepth, 0) = Footnote_String
0038 Else
0039 Footnote_String = Footnote_String_Saved(iDepth - 1, 0)
0040 iDepth_Saved = iDepth
0041 Footnote_String = Footnote_String & "." & rsTableControl.Fields(0).Value
0042 Footnote_String_Saved(iDepth, 0) = Footnote_String
0043 End If
0044 End If
0045 'Have we already printed this note?
0046 FN_Blurb = "Footnote " & Footnote_String & IIf(rsTableControl.Fields(6).Value = True, ": (" & rsTableControl.Fields(2).Value & ")", "") & IIf(rsTableControl.Fields(7).Value = True, " (CORRESPONDENT)", "")
0047 If Note_Iteration = 1 Then
0048 strLine = "SELECT Note_Usage_Temp.Note_ID, Note_Usage_Temp.Note_Usage, Note_Usage_Temp.Note_Level, Note_Usage_Temp.Note_From, Note_Usage_Temp.Max_Level FROM Note_Usage_Temp WHERE (Note_Usage_Temp.Note_ID =" & rsTableControl.Fields(1).Value & ");"
0049 Else
0050 strLine = "SELECT Note_Usage_Temp.Note_ID, Note_Usage_Temp.Note_Usage, Note_Usage_Temp.Note_Level , Note_Usage_Temp.Note_From, Note_Usage_Temp.Max_Level FROM Note_Usage_Temp WHERE (((Note_Usage_Temp.Note_ID)=" & rsTableControl.Fields(1).Value & ") AND (Note_Usage_Temp.Note_Usage)<>""" & FN_Blurb & """);"
0051 End If
0052 Set rsTableControl2 = CurrentDb.OpenRecordset(strLine)
0053 If rsTableControl2.EOF Then
0054 If Note_Iteration = 1 Then
0055 rsTableControl2.AddNew
0056 rsTableControl2.Fields(0) = rsTableControl.Fields(1).Value
0057 rsTableControl2.Fields(1) = FN_Blurb
0058 rsTableControl2.Fields(2) = iDepth
0059 rsTableControl2.Fields(3) = iFootNoteID
0060 rsTableControl2.Fields(4) = maxDepth
0061 rsTableControl2.Update
0062 Else
0063 strLine = "<P ALIGN=""Left""><FONT Size = 2 FACE=""Arial""><B><U>" & IIf(rsTableControl.Fields(7).Value = True, "<FONT COLOR = ""800080"">", "") & FN_Blurb & "</B></U></P>"
0064 tsTextFile.WriteLine strLine
0065 strLine = "<P ALIGN=""Justify""><FONT Size = 2 FACE=""Arial"">"
0066 tsTextFile.WriteLine strLine
0067 strLine = rsTableControl.Fields(3).Value & IIf(rsTableControl.Fields(7).Value = True, "<FONT COLOR = ""000000"">", "")
0068 If IsMissing(SuppressPrivate) Or rsTableControl.Fields(5).Value <> "Yes" Then
0069 'Check this!!!!!
0070 OK = Notes_Text_Format(rsTableControl.Fields(1).Value, rsTableControl.Fields(1).Value, strLine, 0, "N/A", IIf(This_Note_Group = Note_Group, maxDepth - iDepth_Local, 0))
0071 'Write out the in-page Footnotes
0072 strQuery = "SELECT Note_Footnotes.* FROM Note_Footnotes WHERE ((([Note_Footnotes]![Note_ID]) = " & rsTableControl.Fields(1).Value & ")) ORDER BY Note_Footnotes!FN_ID;"
0073 Set rsNotesLinks = CurrentDb.OpenRecordset(strQuery)
0074 If Not rsNotesLinks.EOF Then
0075 rsNotesLinks.MoveFirst
0076 strLineTemp = "<BR><HR><BR><U><B>In-Page Footnotes</U></B>"
0077 Last_Footnote_Bulletted = "No"
0078 Do While Not rsNotesLinks.EOF
0079 'Format the in-page Footnotes
0080 If Last_Footnote_Bulletted = "Yes" Then
0081 strLine_Break = ""
0082 Else
0083 strLine_Break = "<BR><BR>"
0084 End If
0085 If InStr(Right(Trim(rsNotesLinks.Fields(2).Value), 4), "|") > 0 Then 'Determine if the footnote ends in a bulleted list. If so, don't add line breaks next time ...
0086 Last_Footnote_Bulletted = "Yes"
0087 Else
0088 Last_Footnote_Bulletted = "No"
0089 End If
0090 strLineTemp = strLineTemp & "<a name=""On-Page_Link_" & rsTableControl.Fields(1) & "_" & rsNotesLinks.Fields(1).Value & """></A>" & strLine_Break & "<B>Footnote " & rsNotesLinks.Fields(1).Value & "</B>: " & rsNotesLinks.Fields(2).Value
0091 rsNotesLinks.MoveNext
0092 Loop
0093 strLine = strLine & "<BR><BR>"
0094 strLineTemp = Remove_Dummy_Ref(strLineTemp)
0095 strLineTemp = WebEncode(strLineTemp)
0096 strLineTemp = ImageRef(strLineTemp, "NoteFootnotes", "X", 0, 0, iDepth)
0097 OK = Reference_Books(strLineTemp, "X", 0, 0)
0098 OK = Reference_Author(strLineTemp, "X", 0, 0) 'Replace the Author References by hyperlinks
0099 OK = Reference_Note_Links(strLineTemp, "N", 0, 0) 'Replace the Author References by hyperlinks
0100 OK = Reference_Reference(strLineTemp) 'Replace References
0101 OK = Reference_Papers(strLineTemp, "X", 0, 0)
0102 OK = Reference_Notes(strLineTemp, "X", 0, 0)
0103 OK = Reference_Code(strLineTemp)
0104 OK = Reference_Code_Bridge(strLineTemp)
0105 OK = Reference_Tables(strLineTemp) 'Replace Table-references by hyperlinks
0106 OK = Reference_Queries(strLineTemp) 'Replace Query-references by hyperlinks
0107 OK = Reference_Webrefs(strLineTemp, "X", 0, 0, "Show")
0108 strLineTemp = NumberedBullets(strLineTemp)
0109 strLineTemp = Bullets(strLineTemp)
0110 OK = Mark_Colours(strLineTemp)
0111 strLine = strLine & strLineTemp
0112 End If
0113 Set rsNotesLinks = Nothing
0114 If rsTableControl.Fields(4).Value & "" = "" Then
0115 DatePrint = 0
0116 Else
0117 DatePrint = rsTableControl.Fields(4).Value / 1000
0118 End If
0119 strLine = strLine & "</P><B>Note last updated:</B> " & DatePrint & "<BR><BR><HR>"
0120 Else
0121 strLine = "The note is private.<BR><HR>"
0122 End If
0123 'Any offset references will be up an extra level
0124 strLine = Replace(strLine, """../", """../../")
0125 strLine = Replace(strLine, """../../../../", """../../../") 'Added 31/03/2020 ... a bit of a fudge!
0126 'strLine = Replace(strLine, "Notes_Print/", "") '***** why was this here?
0127 tsTextFile.WriteLine strLine
0128 End If
0129 Else
0130 rsTableControl2.MoveFirst
0131 If Note_Iteration = 1 Then
0132 rsTableControl2.AddNew
0133 rsTableControl2.Fields(0) = rsTableControl.Fields(1).Value
0134 rsTableControl2.Fields(1) = FN_Blurb
0135 rsTableControl2.Fields(2) = iDepth
0136 rsTableControl2.Fields(3) = iFootNoteID
0137 rsTableControl2.Fields(4) = maxDepth
0138 rsTableControl2.Update
0139 Else
0140 If strPrintDuplicateFootnoteRefs = "Yes" Then
0141 Footnote_String_Saved(iDepth, 1) = "Duplicated"
0142 If iDepth > 0 Then
0143 If Footnote_String_Saved(iDepth - 1, 1) = "" Then
0144 strLine = "<P ALIGN=""Left""><FONT Size = 2 FACE=""Arial""><B><U>" & "Footnote " & Footnote_String & " Repeated</B></U>. See " & rsTableControl2.Fields(1).Value & "</P><HR>"
0145 tsTextFile.WriteLine strLine
0146 End If
0147 Else
0148 strLine = "<P ALIGN=""Left""><FONT Size = 2 FACE=""Arial""><B><U>" & "Footnote " & Footnote_String & " Repeated</B></U>. See " & rsTableControl2.Fields(1).Value & "</P><HR>"
0149 tsTextFile.WriteLine strLine
0150 End If
0151 End If
0152 End If
0153 End If
0154 'Next Footnotes - recursively
0155 If (iDepth_Local < maxDepth) And (This_Note_Group = Note_Group) Then 'Don't iterate for "foreign" Notes
0156 iFootNoteID_Local = rsTableControl.Fields(1).Value
0157 OK_Local = NoteFootnotes(tsTextFile, iFootNoteID_Local, maxDepth, iDepth_Local, SuppressPrivate)
0158 End If
0159 rsTableControl.MoveNext
0160 Loop
0161End If
0162Set rsTableControl = Nothing
0163Set rsTableControl2 = Nothing
0164End Function

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


Source Code of: NoteForPrinting
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 248
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function NoteForPrinting(iFootNoteID, maxDepth, SuppressPrivate, Secure, Timestamp, Processed)
0002Dim iDepth As Variant
0003Dim strLine As String
0004Dim strLineTemp As String
0005Dim srtNotesRoot As String
0006Dim srtNotesRootSecure As String
0007Dim fsoTextFile As FileSystemObject
0008Dim rsTableControl As Recordset
0009Dim rsNotesLinks As Recordset
0010Dim rsFNCheck As Recordset
0011Dim DatePrint As Date
0012Dim i As Integer
0013Dim strFilenameArchive As String
0014Dim strFileName As String
0015Dim strFolder As String
0016Dim x As Long
0017Dim srtNotesSubRoot As String
0018Dim srtNotesSubRootSecure As String
0019Dim strNotesSubdirectory As String
0020Dim strTempNote As String
0021Dim strQuery As String
0022Dim iImmediate As Integer
0023Dim Last_Footnote_Bulletted As String
0024Dim strLine_Break As String
0025Dim strHeader As String
0026Dim strDup_FNs As String
0027iDepth = 0
0028'Clear the Notes usage table
0029 DoCmd.RunSQL ("DELETE Note_Usage_Temp.* FROM Note_Usage_Temp;")
0030'Prepopulate with the main note
0031 strLine = "SELECT Note_Usage_Temp.* FROM Note_Usage_Temp;"
0032Set rsTableControl = CurrentDb.OpenRecordset(strLine)
0033rsTableControl.AddNew
0034rsTableControl.Fields(0) = iFootNoteID
0035rsTableControl.Fields(1) = "Main Text"
0036rsTableControl.Fields(4) = maxDepth
0037rsTableControl.Update
0038'Initialise the output file
0039Set fsoTextFile = New FileSystemObject
0040srtNotesRoot = TheoWebsiteRoot & "\Notes\"
0041srtNotesSubRoot = "Notes_Print\"
0042srtNotesRootSecure = TheoWebsiteRoot & "\Secure_Jen\"
0043srtNotesSubRootSecure = "Notes_Print\"
0044 strNotesSubdirectory = "Notes_" & Find_New_Directory(iFootNoteID) & "\"
0045If Secure = 10 Then
0046 strFolder = srtNotesRootSecure
0047 strFolder = strFolder & strNotesSubdirectory & srtNotesSubRootSecure
0048Else
0049 strFolder = srtNotesRoot
0050 strFolder = strFolder & strNotesSubdirectory & srtNotesSubRoot
0051End If
0052strFileName = "NotesPrint_" & iFootNoteID & "_" & maxDepth & IIf(SuppressPrivate = "Yes", "_P", "") & IIf(strPrintDuplicateFootnoteRefs = "Yes", "_D", "") & IIf(strPrintReadingLists = "Yes", "_R", "")
0053strFilenameArchive = ""
0054If Processed & "" = "No" Then
0055 strFilenameArchive = strFileName & "_" & Timestamp & ".htm"
0056End If
0057strFileName = strFileName & ".htm"
0058Set tsTextFile = fsoTextFile.CreateTextFile(strFolder & strFileName, True, True)
0059'Read the Note
0060 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Notes.Item_Title, Notes.Item_Text, Notes.Last_Changed, Note_Groups.Note_Group, Notes.[Title?], Notes.[Respondent?], Notes.Note_Group FROM Notes INNER JOIN Note_Groups ON Notes.Note_Group = Note_Groups.ID WHERE (((Notes.ID)=" & iFootNoteID & "));")
0061If rsTableControl.EOF Then
0062 MsgBox ("Non-existent Note " & iFootNoteID)
0063 Exit Function
0064Else
0065 rsTableControl.MoveFirst
0066End If
0067Note_Group = rsTableControl.Fields(6).Value
0068'Print main Note
0069'Heading
0070Colour_Table(0, 4) = 1
0071If rsTableControl.Fields(5).Value = True Then
0072 Colour_Table(2, 4) = 1
0073End If
0074If rsTableControl.Fields(4).Value = False Then
0075 strHeader = rsTableControl.Fields(3).Value
0076Else
0077 strHeader = rsTableControl.Fields(3).Value & " - " & rsTableControl.Fields(0).Value
0078End If
0079strLine = "<!DOCTYPE html><html lang=""en""><head><meta charset=""utf-8""><title>Printable Note - " & strHeader & " (Theo Todman's Web Page) </title><link href=""../../../TheosStyle.css"" rel=""stylesheet"" type=""text/css""><link rel=""shortcut icon"" href=""../../../TT_ICO.png"" /></head>"
0080tsTextFile.WriteLine strLine
0081strLine = "<P ALIGN=""Center""><FONT Size = 3 FACE=""Arial""><B><HR>Theo Todman's Web Page<HR><p>For Text Colour-conventions (at end of page): <A HREF=""#ColourConventions"">Click Here</a></p><U>" & strHeader & "</B></U></P>"
0082tsTextFile.WriteLine strLine
0083'Note
0084strLine = "<P ALIGN=""Justify""><FONT Size = 2 FACE=""Arial"">"
0085tsTextFile.WriteLine strLine
0086strLine = rsTableControl.Fields(1).Value
0087 strLine = ReplaceCode(strLine, "|Colour_1|", "|Colour_0|")
0088If rsTableControl.Fields(5).Value = True Then
0089 strLine = "|Colour_2|" & strLine
0090End If
0091 OK = Notes_Text_Format(iFootNoteID, 0, strLine, 0, "N/A", maxDepth)
0092'Write out the in-page Footnotes
0093 strQuery = "SELECT Note_Footnotes.* FROM Note_Footnotes WHERE ((([Note_Footnotes]![Note_ID]) = " & iFootNoteID & ")) ORDER BY Note_Footnotes!FN_ID;"
0094Set rsNotesLinks = CurrentDb.OpenRecordset(strQuery)
0095If Not rsNotesLinks.EOF Then
0096 rsNotesLinks.MoveFirst
0097 strLineTemp = "|Colour_0|<BR><HR><BR><U><B>In-Page Footnotes</U></B>"
0098 Last_Footnote_Bulletted = "No"
0099 Do While Not rsNotesLinks.EOF
0100 'Format the in-page Footnotes
0101 If rsNotesLinks(1) = rsNotesLinks(4) Then 'Allow for Duplicate FNs
0102 If Last_Footnote_Bulletted = "Yes" Then
0103 strLine_Break = ""
0104 Else
0105 strLine_Break = "<BR><BR>"
0106 End If
0107 If InStr(Right(Trim(rsNotesLinks.Fields(2).Value), 4), "|") > 0 Then 'Determine if the footnote ends in a bulleted list. If so, don't add line breaks next time ...
0108 Last_Footnote_Bulletted = "Yes"
0109 Else
0110 Last_Footnote_Bulletted = "No"
0111 End If
0112 'Check, and list, Duplicate FNs
0113 strDup_FNs = ""
0114 Set rsFNCheck = CurrentDb.OpenRecordset("SELECT Note_Footnotes.Note_ID, Note_Footnotes.FN_ID, Note_Footnotes.Master_ID FROM Note_Footnotes WHERE (((Note_Footnotes.Note_ID) = " & iFootNoteID & ") And ((Note_Footnotes.FN_ID) <> [Note_Footnotes]![Master_ID]) And ((Note_Footnotes.Master_ID) = " & rsNotesLinks(1) & ")) ORDER BY Note_Footnotes.FN_ID;")
0115 If Not rsFNCheck.EOF Then
0116 rsFNCheck.MoveFirst
0117 Do While Not rsFNCheck.EOF
0118 strDup_FNs = strDup_FNs & ", " & rsFNCheck.Fields(1).Value
0119 rsFNCheck.MoveNext
0120 Loop
0121 End If
0122 Set rsFNCheck = Nothing
0123 strLineTemp = strLineTemp & "<a name=""On-Page_Link_" & iFootNoteID & "_" & rsNotesLinks.Fields(1).Value & """></A>" & strLine_Break & "<B>Footnote" & IIf(strDup_FNs = "", " ", "s ") & rsNotesLinks.Fields(1).Value & strDup_FNs & "</B>: " & rsNotesLinks.Fields(2).Value
0124 End If
0125 rsNotesLinks.MoveNext
0126 Loop
0127 strLineTemp = strLineTemp & "<BR><BR>"
0128 strLineTemp = ReplaceCode(strLineTemp, "|Colour_1|", "|Colour_0|")
0129 strLineTemp = Remove_Dummy_Ref(strLineTemp)
0130 strLineTemp = WebEncode(strLineTemp)
0131 strLineTemp = ImageRef(strLineTemp, "NotesPrint", "X", 0, 0)
0132 OK = Reference_Books(strLineTemp, "X", 0, 0)
0133 OK = Reference_Author(strLineTemp, "X", 0, 0) 'Replace the Author References by hyperlinks
0134 OK = Reference_Note_Links(strLineTemp, "NP", 0, 0) 'Replace the Note Links References by hyperlinks
0135 OK = Reference_Reference(strLineTemp) 'Replace References
0136 OK = Reference_Papers(strLineTemp, "X", 0, 0)
0137 OK = Reference_Notes(strLineTemp, "X", 0, 0)
0138 OK = Reference_Code(strLineTemp)
0139 OK = Reference_Code_Bridge(strLineTemp)
0140 OK = Reference_Tables(strLineTemp) 'Replace Table-references by hyperlinks
0141 OK = Reference_Queries(strLineTemp) 'Replace Query-references by hyperlinks
0142 OK = Reference_Webrefs(strLineTemp, "X", 0, 0, "Show")
0143 strLineTemp = NumberedBullets(strLineTemp)
0144 strLineTemp = Bullets(strLineTemp)
0145 OK = Mark_Colours(strLineTemp)
0146 OK = Classification_Change(strLineTemp)
0147 strLine = strLine & strLineTemp
0148End If
0149Set rsNotesLinks = Nothing
0150strLine = strLine & IIf(rsTableControl.Fields(4).Value = True, "<FONT COLOR = ""000000"">", "")
0151'Any offset references will be up an extra level
0152strLine = Replace(strLine, """../", """../../")
0153strLine = Replace(strLine, """../../../../", """../../../") 'Added 31/03/2020
0154strLine = Replace(strLine, """Notes_Print/NotesPrint", """NotesPrint")
0155DatePrint = Val(rsTableControl.Fields(2).Value & "") / 1000
0156strLine = strLine & "</P><B>Note last updated:</B> " & DatePrint & "<BR>"
0157tsTextFile.WriteLine strLine
0158strLine = "</P><HR>"
0159tsTextFile.WriteLine strLine
0160'Footnotes
0161For i = 0 To 19 'Clear the Saved Array
0162 Footnote_String_Saved(i, 0) = ""
0163 Footnote_String_Saved(i, 1) = ""
0164Next i
0165If maxDepth > 0 Then
0166 If SuppressPrivate = "Yes" Then
0167 Note_Iteration = 1
0168 OK = NoteFootnotes(tsTextFile, iFootNoteID, maxDepth, iDepth, "Yes")
0169 For i = 0 To 19 'Clear the Saved Array
0170 Footnote_String_Saved(i, 0) = ""
0171 Footnote_String_Saved(i, 1) = ""
0172 Next i
0173 DoCmd.OpenQuery ("Note_Usage_Temp_Zapper_Zap")
0174 DoCmd.OpenQuery ("Note_Usage_Temp_Zapper_GEN")
0175 DoCmd.OpenQuery ("Note_Usage_Temp_Zap")
0176 DoCmd.OpenQuery ("Note_Usage_Temp_Zapper_Zap")
0177 DoCmd.OpenQuery ("Note_Usage_Temp_Zapper_GEN2")
0178 DoCmd.OpenQuery ("Note_Usage_Temp_Zap")
0179 DoCmd.OpenQuery ("Note_Usage_Temp_Zapper_Zap")
0180 Note_Iteration = 2
0181 OK = NoteFootnotes(tsTextFile, iFootNoteID, maxDepth, iDepth, "Yes")
0182 Else
0183 Note_Iteration = 1
0184 OK = NoteFootnotes(tsTextFile, iFootNoteID, maxDepth, iDepth)
0185 For i = 0 To 19 'Clear the Saved Array
0186 Footnote_String_Saved(i, 0) = ""
0187 Footnote_String_Saved(i, 1) = ""
0188 Next i
0189 DoCmd.OpenQuery ("Note_Usage_Temp_Zapper_Zap")
0190 DoCmd.OpenQuery ("Note_Usage_Temp_Zapper_GEN")
0191 DoCmd.OpenQuery ("Note_Usage_Temp_Zap")
0192 DoCmd.OpenQuery ("Note_Usage_Temp_Zapper_Zap")
0193 DoCmd.OpenQuery ("Note_Usage_Temp_Zapper_GEN2")
0194 DoCmd.OpenQuery ("Note_Usage_Temp_Zap")
0195 DoCmd.OpenQuery ("Note_Usage_Temp_Zapper_Zap")
0196 Note_Iteration = 2
0197 OK = NoteFootnotes(tsTextFile, iFootNoteID, maxDepth, iDepth)
0198 End If
0199End If
0200'Reading Lists are optional (system parameter) for Archived Notes ... so need careful processing
0201'Accummulate the end of the page ...
0202strLine = "<a name=""ColourConventions""></a><BR><P ALIGN=""Left""><FONT Size = 2 FACE=""Arial""><B><U>Text Colour Conventions</U></B><OL TYPE=""1"">"
0203For i = 0 To 19
0204 If Colour_Table(i, 4) = "1" Then
0205 strLine = strLine & "<LI><FONT COLOR = """ & Colour_Table(i, 1) & """>" & Colour_Table(i, 2) & "</FONT>: " & Colour_Table(i, 3)
0206 End If
0207Next i
0208strLine = strLine & "</OL>"
0209'Add timestamp & link to home-page
0210strLine = strLine & "<hr><BR><a href = ""../../../index.htm"">Return to Home page</a>"
0211strLine = strLine & "<BR><B>Timestamp: " & Now() & ". Comments to <U>theo@theotodman.com</U>.</B></P>"
0212strLine = strLine & "</BODY></HTML>"
0213'Determine if a temp Note
0214strTempNote = "Temp"
0215Set rsNotesLinks = Nothing
0216 strLineTemp = "SELECT Notes.Status, Notes.Immediate_Promotion FROM Notes WHERE (((Notes.ID)=" & iFootNoteID & "));"
0217Set rsNotesLinks = CurrentDb.OpenRecordset(strLineTemp)
0218If Not rsNotesLinks.EOF Then
0219 rsNotesLinks.MoveFirst
0220 strTempNote = rsNotesLinks.Fields(0).Value & ""
0221 iImmediate = rsNotesLinks.Fields(1).Value
0222End If
0223Set rsNotesLinks = Nothing
0224'Create Archive file ...
0225If strFilenameArchive <> "" Then
0226 'Add the Reading List if appropriate ...
0227 If strPrintReadingLists = "Yes" And Archive_Reading_Lists = True Then
0228 OK = AddReading_List(rsTableControl.Fields(0), tsTextFile, , "Yes")
0229 End If
0230 OK = CopyToArchive(strFolder, strFileName, strFilenameArchive, strLine)
0231 If SuppressPrivate = "Yes" Then
0232 OK = CopyToTransfer(strFolder, strFilenameArchive)
0233 End If
0234End If
0235'Add the Reading List
0236If strPrintReadingLists = "Yes" Then
0237 OK = AddReading_List(rsTableControl.Fields(0), tsTextFile, , "Yes")
0238End If
0239tsTextFile.WriteLine strLine
0240'Publish - but not Temp Notes, unless "immediate"
0241If strTempNote <> "Temp" Or iImmediate = -1 Then
0242 If SuppressPrivate = "Yes" Then
0243 OK = CopyToTransfer(strFolder, strFileName)
0244 End If
0245End If
0246Set tsTextFile = Nothing
0247Set rsTableControl = Nothing
0248End Function

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


Source Code of: Query_Use_Checker
Procedure Type: Public Function
Module: Documentation
Lines of Code: 137
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Query_Use_Checker(Object, Object_Type, Code)
0002Dim Code_Local As String
0003Dim strObject As String
0004Dim strObjectType As String
0005Dim strTest As String
0006Dim i As Long
0007Dim j As Long
0008Dim k As Long
0009Dim strCheck As String
0010Dim iTest As Long
0011Dim iTestSaved As String
0012Dim rsTableToUpdate As Recordset
0013Dim Reference_OK As Boolean
0014Dim strQueryType As String
0015Dim strBefore As String
0016Dim strAfter As String
0017'This sub (based on Sub_Function_Call_Checker) searches an object (Code or Query) for references to table or query names, as extracted from the Query_Definitions and Table_Definitions tables
0018Code_Local = Code
0019rsQueryDB.MoveFirst
0020iTestSaved = 0
0021Do Until rsQueryDB.EOF
0022 strObject = rsQueryDB.Fields(0)
0023 strObjectType = rsQueryDB.Fields(1)
0024 i = InStr(Code_Local, strObject)
0025 iTestSaved = 0
0026 Do While i > 0
0027 If Object_Type = "C" Then
0028 'Code .....
0029 'Ignore false positives
0030 strAfter = Mid(Code_Local, i + Len(strObject), 1)
0031 'Check Following character
0032 If strAfter = " " Or strAfter = ")" Or strAfter = "]" Or strAfter = "." Or strAfter = """" Or strAfter = ";" Then 'This needs to be made more sophisticated
0033 strBefore = Mid(Code_Local, i - 1, 1)
0034 'And check preceeding character
0035 If strBefore = " " Or strBefore = "(" Or strBefore = "[" Or strBefore = """" Then 'This needs to be made more sophisticated
0036 'Now check for part of longer name ...
0037 If Not (strAfter = " " And strBefore = """") And Not (strAfter = """" And strBefore = " ") Then
0038 'Find the line number
0039 j = i - 1
0040 strTest = ""
0041 Do Until strTest = Chr$(10) Or j = 1
0042 strTest = Mid(Code_Local, j, 1)
0043 j = j - 1
0044 Loop
0045 If j = 1 Then
0046 Else
0047 j = j + 2
0048 End If
0049 Reference_OK = True
0050 strCheck = Mid(Code_Local, j + 4, i - j - 4)
0051 k = InStr(strCheck, "'") + InStr(strCheck, "Debug.Print") + InStr(strCheck, "MsgBox")
0052 'Exclude Comments, Debug and MsgBox items ... Any other false positives?
0053 If k > 0 Then
0054 Reference_OK = False
0055 End If
0056 If Reference_OK = True Then
0057 'Update the database
0058 If Mid(Code_Local, j, 1) <> "<" Then 'Not already a Name applied to this line
0059 'But, could this be a Code Name with a Query also in the same line?
0060 iTest = Val(Mid(Code_Local, j, 4))
0061 If iTestSaved <> iTest Then
0062 rsQueryLinksDB.AddNew
0063 rsQueryLinksDB.Fields(0) = Object
0064 rsQueryLinksDB.Fields(1) = Object_Type
0065 rsQueryLinksDB.Fields(2) = strObject
0066 rsQueryLinksDB.Fields(3) = strObjectType
0067 rsQueryLinksDB.Fields(4) = iTest
0068 'Required for duplicates ... maybe there's a better way?
0069 On Error Resume Next
0070 rsQueryLinksDB.Update
0071 End If
0072 iTestSaved = iTest
0073 'Update the Code line with a Name and a hyperlink (if this line not already "bagged") ...
0074 If strObjectType = "T" Then
0075 Code_Local = Left(Code_Local, j - 1) & "<A Name=""" & Object & "_" & iTest & """></A><A HREF=""" & SubSystem & "Documentation_Code_Tables.htm#" & strObject & """>" & Mid(Code_Local, j, 4) & "</A>" & Mid(Code_Local, j + 4, Len(Code_Local))
0076 'Adjust the cursor ...
0077 i = i + 9 + Len(Object) + 1 + Len(iTest) + 41 + Len(strObject) + 2 + 4 + 4 + 4
0078 Else
0079 If strObjectType = "Q" Then
0080 strQueryType = rsQueryDB.Fields(2)
0081 Code_Local = Left(Code_Local, j - 1) & "<A Name=""" & Object & "_" & iTest & """></A><A HREF=""" & SubSystem & "Documentation_Code_Queries_" & strQueryType & ".htm#" & strObject & """>" & Mid(Code_Local, j, 4) & "</A>" & Mid(Code_Local, j + 4, Len(Code_Local))
0082 'Adjust the cursor ...
0083 i = i + 9 + Len(Object) + 1 + Len(iTest) + 38 + Len(strQueryType) + 4 + Len(strObject) + 2 + 4 + 4 + 4
0084 Else
0085 If strObjectType = "F" Then
0086 Code_Local = Left(Code_Local, j - 1) & "<A Name=""" & Object & "_" & iTest & """></A><A HREF=""" & SubSystem & "Documentation_Code_Fragments.htm#" & strObject & """>" & Mid(Code_Local, j, 4) & "</A>" & Mid(Code_Local, j + 4, Len(Code_Local))
0087 'Adjust the cursor ...
0088 i = i + 9 + Len(Object) + 1 + Len(iTest) + 44 + Len(strObject) + 2 + 4 + 4 + 4
0089 End If
0090 End If
0091 End If
0092 End If
0093 End If
0094 End If
0095 End If
0096 End If
0097 Else
0098 'Queries .....
0099 'Ignore false positives
0100 strTest = Mid(Code_Local, i + Len(strObject), 1)
0101 'Check Following character
0102 If strTest = " " Or strTest = ")" Or strTest = "]" Or strTest = ";" Or strTest = "." Or Asc(strTest) < 32 Then 'This needs to be made more sophisticated
0103 strTest = Mid(Code_Local, i - 1, 1)
0104 'And check preceeding character
0105 If strTest = " " Or strTest = "(" Or strTest = "[" Then 'This needs to be made more sophisticated
0106 'Check if this line has already been "done" ...
0107 'Update the database
0108 rsQueryLinksDB.AddNew
0109 rsQueryLinksDB.Fields(0) = Object
0110 rsQueryLinksDB.Fields(1) = Object_Type
0111 rsQueryLinksDB.Fields(2) = strObject
0112 rsQueryLinksDB.Fields(3) = strObjectType
0113 rsQueryLinksDB.Update
0114 'Stop looking for this Object
0115 i = Len(Code_Local) - 1
0116 iTestSaved = iTest
0117 End If
0118 End If
0119 End If
0120 i = InStr(i + 1, Code_Local, strObject)
0121 Loop
0122 rsQueryDB.MoveNext
0123 iTestSaved = 0
0124Loop
0125If Object_Type = "C" Then
0126 If Code <> Code_Local Then
0127 'Update the Code database
0128 Code = Code_Local
0129 Set rsTableToUpdate = CurrentDb.OpenRecordset("Select Code from Code_Table WHERE Procedure_Name = """ & Object & """;")
0130 rsTableToUpdate.MoveFirst
0131 rsTableToUpdate.Edit
0132 rsTableToUpdate.Fields(0) = Code
0133 rsTableToUpdate.Update
0134 End If
0135End If
0136Query_Use_Checker = "OK"
0137End Function

Procedures Calling This Procedure (Query_Use_Checker) Tables / Queries / Fragments Directly Used By This Procedure (Query_Use_Checker) 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