Line-No. / Ref. Code Line
0001 Public Function NoteFootnotes(tsTextFile As TextStream, iFootNoteID, maxDepth, iDepth, Optional SuppressPrivate)
0002 Dim iFootNoteID_Local As Integer
0003 Dim iDepth_Local As Integer
0004 Dim strLine As String
0005 Dim strLineTemp As String
0006 Dim rsTableControl As Recordset
0007 Dim rsTableControl2 As Recordset
0008 Dim rsNotesLinks As Recordset
0009 Dim OK_Local As String
0010 Dim FN_Blurb As String
0011 Dim DatePrint As Date
0012 Dim i As Integer
0013 Dim This_Note_Group
0014 Dim strQuery As String
0015 Dim Last_Footnote_Bulletted As String
0016 Dim strLine_Break As String
0017 'Footnotes
0018 iDepth_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;")
0020 If rsTableControl.EOF Then
0021 Else
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 = "" & IIf(rsTableControl.Fields(7).Value = True, "", "") & FN_Blurb & "
"
0064 tsTextFile.WriteLine strLine
0065 strLine = ""
0066 tsTextFile.WriteLine strLine
0067 strLine = rsTableControl.Fields(3).Value & IIf(rsTableControl.Fields(7).Value = True, "", "")
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 = "In-Page Footnotes "
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 = " "
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 & " " & strLine_Break & "Footnote " & rsNotesLinks.Fields(1).Value & " : " & rsNotesLinks.Fields(2).Value
0091 rsNotesLinks.MoveNext
0092 Loop
0093 strLine = strLine & " "
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 & "Note last updated: " & DatePrint & " "
0120 Else
0121 strLine = "The note is private. "
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 = "" & "Footnote " & Footnote_String & " Repeated . See " & rsTableControl2.Fields(1).Value & "
"
0145 tsTextFile.WriteLine strLine
0146 End If
0147 Else
0148 strLine = "" & "Footnote " & Footnote_String & " Repeated . See " & rsTableControl2.Fields(1).Value & "
"
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
0161 End If
0162 Set rsTableControl = Nothing
0163 Set rsTableControl2 = Nothing
0164 End Function
Line-No. / Ref. Code Line
0001 Public Function NoteForPrinting(iFootNoteID, maxDepth, SuppressPrivate, Secure, Timestamp, Processed)
0002 Dim iDepth As Variant
0003 Dim strLine As String
0004 Dim strLineTemp As String
0005 Dim srtNotesRoot As String
0006 Dim srtNotesRootSecure As String
0007 Dim fsoTextFile As FileSystemObject
0008 Dim rsTableControl As Recordset
0009 Dim rsNotesLinks As Recordset
0010 Dim rsFNCheck As Recordset
0011 Dim DatePrint As Date
0012 Dim i As Integer
0013 Dim strFilenameArchive As String
0014 Dim strFileName As String
0015 Dim strFolder As String
0016 Dim x As Long
0017 Dim srtNotesSubRoot As String
0018 Dim srtNotesSubRootSecure As String
0019 Dim strNotesSubdirectory As String
0020 Dim strTempNote As String
0021 Dim strQuery As String
0022 Dim iImmediate As Integer
0023 Dim Last_Footnote_Bulletted As String
0024 Dim strLine_Break As String
0025 Dim strHeader As String
0026 Dim strDup_FNs As String
0027 iDepth = 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;"
0032 Set rsTableControl = CurrentDb.OpenRecordset(strLine)
0033 rsTableControl.AddNew
0034 rsTableControl.Fields(0) = iFootNoteID
0035 rsTableControl.Fields(1) = "Main Text"
0036 rsTableControl.Fields(4) = maxDepth
0037 rsTableControl.Update
0038 'Initialise the output file
0039 Set fsoTextFile = New FileSystemObject
0040 srtNotesRoot = TheoWebsiteRoot & "\Notes\"
0041 srtNotesSubRoot = "Notes_Print\"
0042 srtNotesRootSecure = TheoWebsiteRoot & "\Secure_Jen\"
0043 srtNotesSubRootSecure = "Notes_Print\"
0044 strNotesSubdirectory = "Notes_" & Find_New_Directory(iFootNoteID) & "\"
0045 If Secure = 10 Then
0046 strFolder = srtNotesRootSecure
0047 strFolder = strFolder & strNotesSubdirectory & srtNotesSubRootSecure
0048 Else
0049 strFolder = srtNotesRoot
0050 strFolder = strFolder & strNotesSubdirectory & srtNotesSubRoot
0051 End If
0052 strFileName = "NotesPrint_" & iFootNoteID & "_" & maxDepth & IIf(SuppressPrivate = "Yes", "_P", "") & IIf(strPrintDuplicateFootnoteRefs = "Yes", "_D", "") & IIf(strPrintReadingLists = "Yes", "_R", "")
0053 strFilenameArchive = ""
0054 If Processed & "" = "No" Then
0055 strFilenameArchive = strFileName & "_" & Timestamp & ".htm"
0056 End If
0057 strFileName = strFileName & ".htm"
0058 Set 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 & "));")
0061 If rsTableControl.EOF Then
0062 MsgBox ("Non-existent Note " & iFootNoteID)
0063 Exit Function
0064 Else
0065 rsTableControl.MoveFirst
0066 End If
0067 Note_Group = rsTableControl.Fields(6).Value
0068 'Print main Note
0069 'Heading
0070 Colour_Table(0, 4) = 1
0071 If rsTableControl.Fields(5).Value = True Then
0072 Colour_Table(2, 4) = 1
0073 End If
0074 If rsTableControl.Fields(4).Value = False Then
0075 strHeader = rsTableControl.Fields(3).Value
0076 Else
0077 strHeader = rsTableControl.Fields(3).Value & " - " & rsTableControl.Fields(0).Value
0078 End If
0079 strLine = "Printable Note - " & strHeader & " (Theo Todman's Web Page) "
0080 tsTextFile.WriteLine strLine
0081 strLine = " Theo Todman's Web PageFor Text Colour-conventions (at end of page): Click Here
" & strHeader & "
"
0082 tsTextFile.WriteLine strLine
0083 'Note
0084 strLine = ""
0085 tsTextFile.WriteLine strLine
0086 strLine = rsTableControl.Fields(1).Value
0087 strLine = ReplaceCode(strLine, "|Colour_1|", "|Colour_0|")
0088 If rsTableControl.Fields(5).Value = True Then
0089 strLine = "|Colour_2|" & strLine
0090 End 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;"
0094 Set rsNotesLinks = CurrentDb.OpenRecordset(strQuery)
0095 If Not rsNotesLinks.EOF Then
0096 rsNotesLinks.MoveFirst
0097 strLineTemp = "|Colour_0|In-Page Footnotes "
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 = " "
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 & " " & strLine_Break & "Footnote" & IIf(strDup_FNs = "", " ", "s ") & rsNotesLinks.Fields(1).Value & strDup_FNs & " : " & rsNotesLinks.Fields(2).Value
0124 End If
0125 rsNotesLinks.MoveNext
0126 Loop
0127 strLineTemp = strLineTemp & " "
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
0148 End If
0149 Set rsNotesLinks = Nothing
0150 strLine = strLine & IIf(rsTableControl.Fields(4).Value = True, "", "")
0151 'Any offset references will be up an extra level
0152 strLine = Replace(strLine, """../", """../../")
0153 strLine = Replace(strLine, """../../../../", """../../../") 'Added 31/03/2020
0154 strLine = Replace(strLine, """Notes_Print/NotesPrint", """NotesPrint")
0155 DatePrint = Val(rsTableControl.Fields(2).Value & "") / 1000
0156 strLine = strLine & "Note last updated: " & DatePrint & " "
0157 tsTextFile.WriteLine strLine
0158 strLine = " "
0159 tsTextFile.WriteLine strLine
0160 'Footnotes
0161 For i = 0 To 19 'Clear the Saved Array
0162 Footnote_String_Saved(i, 0) = ""
0163 Footnote_String_Saved(i, 1) = ""
0164 Next i
0165 If 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
0199 End If
0200 'Reading Lists are optional (system parameter) for Archived Notes ... so need careful processing
0201 'Accummulate the end of the page ...
0202 strLine = "Text Colour Conventions "
0203 For i = 0 To 19
0204 If Colour_Table(i, 4) = "1" Then
0205 strLine = strLine & " " & Colour_Table(i, 2) & " : " & Colour_Table(i, 3)
0206 End If
0207 Next i
0208 strLine = strLine & ""
0209 'Add timestamp & link to home-page
0210 strLine = strLine & "Return to Home page "
0211 strLine = strLine & "Timestamp: " & Now() & ". Comments to theo@theotodman.com . "
0212 strLine = strLine & ""
0213 'Determine if a temp Note
0214 strTempNote = "Temp"
0215 Set rsNotesLinks = Nothing
0216 strLineTemp = "SELECT Notes.Status, Notes.Immediate_Promotion FROM Notes WHERE (((Notes.ID)=" & iFootNoteID & "));"
0217 Set rsNotesLinks = CurrentDb.OpenRecordset(strLineTemp)
0218 If Not rsNotesLinks.EOF Then
0219 rsNotesLinks.MoveFirst
0220 strTempNote = rsNotesLinks.Fields(0).Value & ""
0221 iImmediate = rsNotesLinks.Fields(1).Value
0222 End If
0223 Set rsNotesLinks = Nothing
0224 'Create Archive file ...
0225 If 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
0234 End If
0235 'Add the Reading List
0236 If strPrintReadingLists = "Yes" Then
0237 OK = AddReading_List(rsTableControl.Fields(0), tsTextFile, , "Yes")
0238 End If
0239 tsTextFile.WriteLine strLine
0240 'Publish - but not Temp Notes, unless "immediate"
0241 If strTempNote <> "Temp" Or iImmediate = -1 Then
0242 If SuppressPrivate = "Yes" Then
0243 OK = CopyToTransfer(strFolder, strFileName)
0244 End If
0245 End If
0246 Set tsTextFile = Nothing
0247 Set rsTableControl = Nothing
0248 End Function
Line-No. / Ref. Code Line
0001 Public Function Query_Use_Checker(Object, Object_Type, Code)
0002 Dim Code_Local As String
0003 Dim strObject As String
0004 Dim strObjectType As String
0005 Dim strTest As String
0006 Dim i As Long
0007 Dim j As Long
0008 Dim k As Long
0009 Dim strCheck As String
0010 Dim iTest As Long
0011 Dim iTestSaved As String
0012 Dim rsTableToUpdate As Recordset
0013 Dim Reference_OK As Boolean
0014 Dim strQueryType As String
0015 Dim strBefore As String
0016 Dim 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
0018 Code_Local = Code
0019 rsQueryDB.MoveFirst
0020 iTestSaved = 0
0021 Do 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) & "" & Mid(Code_Local, j, 4) & " " & 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) & "" & Mid(Code_Local, j, 4) & " " & 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) & "" & Mid(Code_Local, j, 4) & " " & 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
0124 Loop
0125 If 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
0135 End If
0136 Query_Use_Checker = "OK"
0137 End Function