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 52 (5 items)

Check_If_In_ContainerAuto_Reference_NotesBackup_Prune_CtrlCode_Archive_Prune
Zap_Duplicate_Files...

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

Go to top of page



Source Code of: Auto_Reference_Notes
Procedure Type: Public Sub
Module: Testing
Lines of Code: 975
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Auto_Reference_Notes(Optional Auto_Local)
0002Dim rsKeyWords As Recordset
0003Dim rsKeyWords_Update As Recordset
0004Dim rsObject As Recordset
0005Dim rsNotes_To_Regen As Recordset
0006Dim rsNotes_To_Regen_Temp As Recordset
0007Dim rsBooks_To_Regen As Recordset
0008Dim rsNotes_Archive As Recordset
0009Dim rsTestNote As Recordset
0010Dim rsAuto_Reference_Notes_Actions As Recordset
0011Dim rsCognate_Array As Recordset
0012Dim strQuery As String
0013Dim iUpdates As Long
0014Dim Duration As Single
0015Dim RunStartTime As Date
0016Dim strKeyWord As String
0017Dim iKeyWord_ID As Integer
0018Dim iObject_ID As Integer
0019Dim strObject_Text As String
0020Dim i As Long
0021Dim j As Long
0022Dim k As Long
0023Dim Link_OK As Boolean
0024Dim Own_Text As Boolean
0025Dim In_Footnote As Boolean
0026Dim Note_Tag As String
0027Dim Note_Tag1 As String
0028Dim Note_Tag2 As String
0029Dim The_Word As String
0030Dim The_Word_OK As Boolean
0031Dim Update_Object As Boolean
0032Dim strTestNote As String
0033Dim Updating_Run_Notes As Boolean
0034Dim Updating_Run_Others As Boolean
0035Dim iCounter As Integer
0036Dim strTitle As String
0037Dim Object_Marker As String
0038Dim DirectoryName As String
0039Dim FileName As String
0040Dim TestFile As String
0041Dim fs As Object
0042Dim strHeader As String
0043Dim strFootnote As String
0044Dim Suppress_Reference As Boolean
0045Dim Ignore_Reference As Boolean
0046Dim strQuestion As String
0047Dim Replace_Reference As Boolean
0048Dim Confirming_Flag As String
0049Dim Exclude As Boolean
0050Dim Object_Exclude As Boolean
0051Dim Non_Updating_Regen As Boolean
0052Dim Last_Notes_Updating_Run As Date
0053Dim Last_Others_Updating_Run As Date
0054Dim strCognates As String
0055Dim New_Links_Unprocessed_Notes As Integer
0056Dim New_Links_Unprocessed_Others As Integer
0057Dim Msg_Response
0058Dim Object_Read As Boolean
0059Dim Suppress_Debug_Printing As Boolean
0060Dim strTable As String
0061Dim strMsg As String
0062Dim iCheck_Start As Long
0063Dim iCheck_End As Long
0064Dim Read_only_Flag As String
0065Dim Cognate_Array(20) As Variant
0066Dim Invalid_Cognates As Boolean
0067Dim StopRun As Boolean
0068Dim strTest_Cognate As String
0069Dim iAfter As Integer
0070Dim iBefore As Long
0071Dim iAfter_Max As Integer
0072Dim iBefore_Max As Long
0073Dim iSpace As Integer
0074Dim The_Word_Checker As String
0075'Flags
0076Dim bool_Already_Linked As Boolean
0077Dim bool_Suppressed As Boolean
0078Dim bool_Accepted As Boolean
0079Dim bool_Ignored As Boolean
0080Dim bool_Quoted_Text As Boolean
0081Dim bool_Footnote As Boolean
0082Dim bool_Check_FN_Quote As Boolean
0083Dim bool_In_Author As Boolean
0084Dim bool_In_HTML_Tag As Boolean
0085Dim bool_Invalid_Cognate As Boolean
0086Dim iQuestions As Integer
0087Dim iMax_Questions As Integer
0088On Error GoTo Error_Found
0089'Parameter
0090iMax_Questions = 5
0091iQuestions = 0
0092If IsMissing(Auto_Local) Then
0093 Suppress_Debug_Printing = False
0094Else
0095 Suppress_Debug_Printing = Auto_Local
0096End If
0097Set fs = CreateObject("Scripting.FileSystemObject")
0098iUpdates = 0
0099New_Links_Unprocessed_Notes = 0
0100New_Links_Unprocessed_Others = 0
0101Confirming_Flag = ""
0102Read_only_Flag = "No"
0103If automatic_processing = "Yes" Then
0104 Non_Updating_Regen = True
0105Else
0106 Non_Updating_Regen = False
0107End If
0108strCognates = ""
0109'Check precisely one Note_Alternates row is selected
0110 strQuery = "SELECT Count(Note_Alternates.ID) AS CountOfID FROM Note_Alternates WHERE (((Note_Alternates.[Auto_Link?])=Yes));"
0111Set rsKeyWords = CurrentDb.OpenRecordset(strQuery)
0112rsKeyWords.MoveFirst
0113If rsKeyWords.Fields(0) = 0 Then
0114 MsgBox ("No Note_Alternates row selected; exiting Auto_Reference_Notes")
0115 Exit Sub
0116Else
0117 If rsKeyWords.Fields(0) > 1 Then
0118 MsgBox ("More than one Note_Alternates row selected; exiting Auto_Reference_Notes")
0119 Exit Sub
0120 End If
0121End If
0122Set rsKeyWords = Nothing
0123'Read the Keywords ... restrict to PID Notes
0124 strQuery = "SELECT Note_Alternates_1.Item_Alt_Title, Note_Alternates.ID, Note_Alternates.Item_Title, Note_Alternates_1.[Exclude_Auto_Link?], Note_Alternates.Last_Auto_Link_Notes, Note_Alternates.Last_Auto_Link_Others, Notes.Note_Group FROM (Note_Alternates INNER JOIN Note_Alternates AS Note_Alternates_1 ON Note_Alternates.Item_Title = Note_Alternates_1.Item_Title) INNER JOIN Notes ON Note_Alternates_1.ID = Notes.ID WHERE (((Note_Alternates.[Auto_Link?]) = Yes) And ((Notes.Note_Group) = 1)) ORDER BY Note_Alternates_1.[Exclude_Auto_Link?] DESC , IIf([Note_Alternates_1]![Item_Alt_Title]=[Note_Alternates_1]![Item_Title],0,1), Note_Alternates_1.Item_Alt_Title;"
0125Set rsKeyWords = CurrentDb.OpenRecordset(strQuery)
0126strHeader = ""
0127Do Until rsKeyWords.EOF
0128 strKeyWord = rsKeyWords.Fields(0)
0129 iKeyWord_ID = rsKeyWords.Fields(1)
0130 Exclude = rsKeyWords.Fields(3)
0131 Object_Exclude = Exclude
0132 If strKeyWord = rsKeyWords.Fields(2) Then
0133 If Exclude = False Then
0134 strHeader = strKeyWord
0135 End If
0136 End If
0137 If strCognates = "" Then
0138 strCognates = "xxxx"
0139 Else
0140 If strCognates = "xxxx" Then
0141 strCognates = """" & strKeyWord & """"
0142 Else
0143 strCognates = strCognates & ", " & """" & strKeyWord & """"
0144 End If
0145 If Object_Exclude = True Then
0146 strCognates = strCognates & " (excluded)"
0147 End If
0148 End If
0149 rsKeyWords.MoveNext
0150Loop
0151 strQuery = "DELETE * FROM Auto_Reference_Notes_Actions WHERE Note_ID = " & iKeyWord_ID & ";"
0152DoCmd.RunSQL (strQuery)
0153 Set rsAuto_Reference_Notes_Actions = CurrentDb.OpenRecordset("SELECT * FROM Auto_Reference_Notes_Actions WHERE Note_ID = " & iKeyWord_ID & ";")
0154'Re-Read the Keywords - but ignore any ending in "?" or those excluded ... again restrict to PID Notes
0155 strQuery = "SELECT Note_Alternates_1.Item_Alt_Title, Note_Alternates.ID, Note_Alternates.Item_Title, Note_Alternates_1.[Exclude_Auto_Link?], Note_Alternates.Last_Auto_Link_Notes, Note_Alternates.Last_Auto_Link_Others FROM (Note_Alternates INNER JOIN Note_Alternates AS Note_Alternates_1 ON Note_Alternates.Item_Title = Note_Alternates_1.Item_Title) INNER JOIN Notes ON Note_Alternates_1.ID = Notes.ID WHERE (((Note_Alternates_1.[Exclude_Auto_Link?]) <> Yes) And ((Note_Alternates.[Auto_Link?]) = Yes) And ((Right([Note_Alternates_1].[Item_Alt_Title], 1)) <> ""?"") And ((Notes.Note_Group) = 1)) ORDER BY IIf([Note_Alternates_1]![Item_Alt_Title]=[Note_Alternates_1]![Item_Title],0,1), Note_Alternates_1.Item_Alt_Title;"
0156Set rsKeyWords = CurrentDb.OpenRecordset(strQuery)
0157If rsKeyWords.EOF Then
0158 If Non_Updating_Regen = False Then
0159 MsgBox ("No links to set!")
0160 End
0161 Else
0162 Exit Sub
0163 End If
0164Else
0165 rsKeyWords.MoveFirst
0166 If rsKeyWords.Fields(4) & "" = "" Then
0167 Last_Notes_Updating_Run = 0
0168 Else
0169 Last_Notes_Updating_Run = rsKeyWords.Fields(4)
0170 End If
0171 If rsKeyWords.Fields(5) & "" = "" Then
0172 Last_Others_Updating_Run = 0
0173 Else
0174 Last_Others_Updating_Run = rsKeyWords.Fields(5)
0175 End If
0176End If
0177If strHeader = "" Then
0178 strHeader = rsKeyWords.Fields(0)
0179End If
0180If Non_Updating_Regen = False Then
0181 If MsgBox("Auto-Reference Notes for " & strHeader & "?", vbYesNo + vbDefaultButton1) <> vbYes Then
0182 MsgBox ("Update the ""Note_Alternates"" Table and try again!")
0183 End
0184 End If
0185 If MsgBox(strHeader & ": Updating Run?", vbYesNo + vbDefaultButton2) = vbYes Then
0186 If MsgBox("Update Notes?", vbYesNo + vbDefaultButton2) = vbYes Then
0187 Updating_Run_Notes = True
0188 Else
0189 Updating_Run_Notes = False
0190 End If
0191 If MsgBox("Update Others?", vbYesNo + vbDefaultButton1) = vbYes Then
0192 Updating_Run_Others = True
0193 Else
0194 Updating_Run_Others = False
0195 End If
0196 If Updating_Run_Notes = True Or Updating_Run_Others = True Then
0197 If MsgBox("Confirm links?", vbYesNo) = vbYes Then
0198 If MsgBox("Confirm All links?", vbYesNo) = vbYes Then
0199 Confirming_Flag = "All"
0200 Else
0201 If MsgBox("Confirm New links only?", vbYesNo) = vbYes Then
0202 Confirming_Flag = "New"
0203 Else
0204 If MsgBox("Now not confirming links. Is this correct?", vbYesNo) = vbNo Then
0205 OK = MsgBox("Exiting ...")
0206 Exit Sub
0207 End If
0208 End If
0209 End If
0210 If (Updating_Run_Others = True) And (Confirming_Flag <> "") Then
0211 If MsgBox("For Books and Papers, query more than half-read items only?", vbYesNo + vbDefaultButton1) = vbYes Then
0212 Read_only_Flag = "Yes"
0213 Else
0214 Read_only_Flag = "No"
0215 End If
0216 End If
0217 End If
0218 End If
0219 Else
0220 Updating_Run_Notes = False
0221 Updating_Run_Others = False
0222 End If
0223Else
0224 Updating_Run_Notes = False
0225 Updating_Run_Others = False
0226End If
0227 OK = DebugPrint(Suppress_Debug_Printing, "Auto-Reference Note ID = " & iKeyWord_ID & " (" & strKeyWord & ") Updating Notes = " & IIf(Updating_Run_Notes = False, "No", "Yes") & "; Updating Others = " & IIf(Updating_Run_Others = False, "No", "Yes"))
0228automatic_processing = "Yes"
0229strFootnote = "++FN|..|"
0230If Updating_Run_Notes = False Or Updating_Run_Others = False Then
0231 strFootnote = strFootnote & "|.|This page was produced after a non-updating run. This might be because it was a test, or simply because it was a re-run after an updating run. "
0232End If
0233strFootnote = strFootnote & "|.|For further comments on methodology, see [this Note]+N1289N+. |..| ++"
0234 strTestNote = "[This page]" & strFootnote & " lists those Objects with links to the above Note, including those updated as a result of automatic Cross-Referencing of Notes (some of which may be spurious and require eliminating). Objects are listed by Object Type within Key-Word variant. "
0235 strTestNote = strTestNote & "Books and Papers that I've completed reading are marked ""<b>***Read***</b>"", which is a statement rather than a command. Further information on methodology is given above the footnotes below. |II|"
0236RunStartTime = Now()
0237'Clear the Notes_To_Regen_Temp table ...
0238 strQuery = "DELETE * FROM Notes_To_Regen_Temp;"
0239DoCmd.RunSQL (strQuery)
0240'Copy Notes_To_Regen to Notes_To_Regen_Temp ...
0241 strQuery = "INSERT INTO Notes_To_Regen_Temp ( Note_ID, [Timestamp] ) SELECT Notes_To_Regen.Note_ID, Notes_To_Regen.Timestamp FROM Notes_To_Regen;"
0242DoCmd.RunSQL (strQuery)
0243StopRun = False
0244Do Until rsKeyWords.EOF
0245 If StopRun = False Then
0246 strKeyWord = rsKeyWords.Fields(0)
0247 'Build the Cognate_Exclusions Table ...
0248 Set rsCognate_Array = CurrentDb.OpenRecordset("SELECT * FROM Excluded_Cognates WHERE Excluded_Cognates.Key_Word = """ & strKeyWord & """;")
0249 If rsCognate_Array.EOF Then
0250 Invalid_Cognates = False
0251 Else
0252 Invalid_Cognates = True
0253 rsCognate_Array.MoveFirst
0254 i = 1
0255 iAfter_Max = 0
0256 iBefore_Max = 0
0257 Do Until rsCognate_Array.EOF
0258 strTest_Cognate = rsCognate_Array.Fields(1)
0259 Cognate_Array(i) = strTest_Cognate
0260 'check for spaces
0261 iSpace = InStr(strTest_Cognate, " ")
0262 If iSpace > 0 Then
0263 If InStr(strTest_Cognate, strKeyWord) > iSpace Then
0264 iBefore = iSpace
0265 If iBefore > iBefore_Max Then
0266 iBefore_Max = iBefore
0267 End If
0268 Else
0269 iAfter = Len(strTest_Cognate)
0270 If iAfter > iAfter_Max Then
0271 iAfter_Max = iAfter
0272 End If
0273 End If
0274 End If
0275 rsCognate_Array.MoveNext
0276 i = i + 1
0277 Loop
0278 End If
0279 iKeyWord_ID = rsKeyWords.Fields(1)
0280 Exclude = rsKeyWords.Fields(3)
0281 'Object_Exclude = Exclude 'I don't think this is right ... all objects shoud start Excluded, and then accepted
0282 Object_Exclude = True
0283 strTestNote = strTestNote & "|1|<b>" & strKeyWord & "</b>|..|"
0284 'Read & process the objects - Notes, Author Narratives, Paper Abstracts, Comments, Book Abstracts, Comments, ...
0285 For iCounter = 0 To 7
0286 Select Case iCounter
0287 Case 0
0288 strQuery = "SELECT Authors.Author_ID, Authors.Author_Name, Authors.Author_Narrative FROM Authors WHERE (((Authors.Author_Narrative) Like ""*" & strKeyWord & "*"")) ORDER BY Authors.Author_Name;"
0289 strTitle = "Authors"
0290 Object_Marker = "A"
0291 Case 1
0292 strQuery = "SELECT Notes.ID, Notes.Item_Title, Notes.Item_Text, Notes.Note_Group, Notes.Status FROM Notes WHERE (((Notes.Item_Text) Like ""*" & strKeyWord & "*"") AND (Notes.Note_Group = 1 OR Notes.Note_Group = 6 OR Notes.Note_Group = 8 OR Notes.Note_Group = 10 OR Notes.Note_Group = 12 OR Notes.Note_Group = 15)) ORDER BY Notes.Item_Title;" 'Only Note_Groups: PID, Write-ups, Animadversions, Supervisions, Religion and Essays
0293 strTitle = "Notes"
0294 Object_Marker = "+"
0295 Case 2
0296 If Read_only_Flag = "No" Then
0297 strQuery = "SELECT Papers.ID, Papers.Author, Papers.Abstract, Papers.Title, Papers.[Read?] FROM Papers WHERE (((Papers.Abstract) Like ""*" & strKeyWord & "*"")) ORDER BY Papers.Author, Papers.Title;"
0298 Else
0299 strQuery = "SELECT Papers.ID, Papers.Author, Papers.Abstract, Papers.Title, Papers.[Read?] FROM Papers WHERE (((Papers.Abstract) Like ""*" & strKeyWord & "*"") AND ((Papers.[Read?])=True)) OR (((Papers.Abstract) Like ""*" & strKeyWord & "*"") AND (([Actual - Total]/[Estimate])>0.5)) ORDER BY Papers.Author, Papers.Title;"
0300 End If
0301 strTitle = "Paper Abstracts"
0302 Object_Marker = "P"
0303 Case 3
0304 If Read_only_Flag = "No" Then
0305 strQuery = "SELECT Papers.ID, Papers.Author, Papers.Comments, Papers.Title, Papers.[Read?] FROM Papers WHERE (((Papers.Comments) Like ""*" & strKeyWord & "*"")) ORDER BY Papers.Author, Papers.Title;"
0306 Else
0307 strQuery = "SELECT Papers.ID, Papers.Author, Papers.Comments, Papers.Title, Papers.[Read?] FROM Papers WHERE (((Papers.Comments) Like ""*" & strKeyWord & "*"") AND ((Papers.[Read?])=True)) OR (((Papers.Comments) Like ""*" & strKeyWord & "*"") AND (([Actual - Total]/[Estimate])>0.5)) ORDER BY Papers.Author, Papers.Title;"
0308 End If
0309 strTitle = "Paper Comments"
0310 Object_Marker = "P"
0311 Case 4
0312 If Read_only_Flag = "No" Then
0313 strQuery = "SELECT Books.ID1, Books.Author, Books.Abstract, Books.Title, Books.[Read?] FROM Books WHERE (((Books.Abstract) Like ""*" & strKeyWord & "*"")) ORDER BY Books.Author, Books.Title;"
0314 Else
0315 strQuery = "SELECT Books.ID1, Books.Author, Books.Abstract, Books.Title, Books.[Read?] FROM Books WHERE (((Books.Abstract) Like ""*" & strKeyWord & "*"") AND ((Books.[Read?])=True)) OR (((Books.Abstract) Like ""*" & strKeyWord & "*"") AND (([Actual - Total]/[Estimate])>0.5)) ORDER BY Books.Author, Books.Title;"
0316 End If
0317 strTitle = "Book Abstracts"
0318 Object_Marker = "B"
0319 Case 5
0320 If Read_only_Flag = "No" Then
0321 strQuery = "SELECT Books.ID1, Books.Author, Books.Comments, Books.Title, Books.[Read?] FROM Books WHERE (((Books.Comments) Like ""*" & strKeyWord & "*"")) ORDER BY Books.Author, Books.Title;"
0322 Else
0323 strQuery = "SELECT Books.ID1, Books.Author, Books.Comments, Books.Title, Books.[Read?] FROM Books WHERE (((Books.Comments) Like ""*" & strKeyWord & "*"") AND ((Books.[Read?])=True)) OR (((Books.Comments) Like ""*" & strKeyWord & "*"") AND (([Actual - Total]/[Estimate])>0.5)) ORDER BY Books.Author, Books.Title;"
0324 End If
0325 strTitle = "Book Comments"
0326 Object_Marker = "B"
0327 Case 6
0328 strQuery = "SELECT Books.ID1, Books.Author, Books.Title, Books.Abstract, Books.[Read?], Books.Comments FROM Books WHERE ((Books.Title) Like ""*" & strKeyWord & "*"") ORDER BY Books.Author, Books.Title;"
0329 strTitle = "Book Title"
0330 Object_Marker = "B"
0331 Case 7
0332 strQuery = "SELECT Papers.ID, Papers.Author, Papers.Title, Papers.Abstract, Papers.[Read?], Papers.Comments FROM Papers WHERE ((Papers.Title) Like ""*" & strKeyWord & "*"") ORDER BY Papers.Author, Papers.Title;"
0333 strTitle = "Paper Title"
0334 Object_Marker = "P"
0335 End Select
0336 Set rsObject = CurrentDb.OpenRecordset(strQuery)
0337 If Not rsObject.EOF Then
0338 strTestNote = strTestNote & "|.|<b>" & strTitle & "</b>|99|"
0339 rsObject.MoveFirst
0340 iObject_ID = rsObject.Fields(0)
0341 If Object_Marker = "B" Or Object_Marker = "P" Then
0342 Object_Read = rsObject.Fields(4)
0343 Else
0344 Object_Read = False
0345 End If
0346 Do Until rsObject.EOF
0347 bool_Already_Linked = False
0348 bool_Suppressed = False
0349 bool_Accepted = False
0350 bool_Ignored = False
0351 bool_Quoted_Text = False
0352 bool_Footnote = False
0353 bool_Check_FN_Quote = False
0354 bool_In_Author = False
0355 bool_In_HTML_Tag = False
0356 bool_Invalid_Cognate = False
0357 If iCounter = 1 And ((iObject_ID = iKeyWord_ID) Or (iObject_ID = 1292) Or (iObject_ID = 874)) Then 'Ignore the Notes for the KeyWord itself, the Note used for this process and the Aeon Note
0358 Else
0359 If iCounter > 5 Then
0360 'Book / Paper Titles
0361 'Need to check for excluded Cognates
0362 If Invalid_Cognates = True Then
0363 OK = Spot_Invalid_Cognates(rsObject.Fields(2), Cognate_Array())
0364 Else
0365 OK = "OK"
0366 End If
0367 If OK <> "OK" Then
0368 Ignore_Reference = True
0369 The_Word_OK = False
0370 bool_Invalid_Cognate = True
0371 Else
0372 Suppress_Reference = False
0373 Object_Exclude = False
0374 End If
0375 'Output Auto_Reference_Notes_Actions row for Book or Paper Titles
0376 rsAuto_Reference_Notes_Actions.AddNew
0377 rsAuto_Reference_Notes_Actions.Fields(0) = iKeyWord_ID
0378 rsAuto_Reference_Notes_Actions.Fields(1) = strKeyWord
0379 rsAuto_Reference_Notes_Actions.Fields(2) = strTitle
0380 rsAuto_Reference_Notes_Actions.Fields(3) = iObject_ID
0381 rsAuto_Reference_Notes_Actions.Fields(4) = ""
0382 rsAuto_Reference_Notes_Actions.Fields(5) = 0
0383 rsAuto_Reference_Notes_Actions.Fields(6) = Now()
0384 rsAuto_Reference_Notes_Actions.Fields(7) = False
0385 rsAuto_Reference_Notes_Actions.Fields(8) = False
0386 rsAuto_Reference_Notes_Actions.Fields(9) = False
0387 rsAuto_Reference_Notes_Actions.Fields(10) = False
0388 rsAuto_Reference_Notes_Actions.Fields(11) = False
0389 rsAuto_Reference_Notes_Actions.Fields(12) = False
0390 rsAuto_Reference_Notes_Actions.Fields(13) = False
0391 rsAuto_Reference_Notes_Actions.Fields(14) = False
0392 rsAuto_Reference_Notes_Actions.Fields(15) = bool_Invalid_Cognate
0393 rsAuto_Reference_Notes_Actions.Update
0394 Else
0395 iObject_ID = rsObject.Fields(0)
0396 strObject_Text = rsObject.Fields(2)
0397 Update_Object = False
0398 'Find the next strKeyWord
0399 i = 1
0400 Link_OK = False
0401 'This is the loop that interrogates a particular object
0402 'Meaning of flags: Note that some flags apply to the Object, and some only to a particular reference in the Object
0403 '... Link_OK: False if the Reference is rejected, or there are no more references in the Object
0404 '... The_Word_OK: Says whether the word found is free of tags - namely brackets or + signs. If it is tagged, we won't be able to tag it again, but the Object ought still to be selectable ...
0405 '... Suppress_Reference: Relates to +XX+. ie. explicit suppression of a reference
0406 '... Object_Exclude:
0407 '... Update_Object: set if we've
0408 '*************************************************************************
0409 Do Until i = 0
0410 bool_Already_Linked = False
0411 bool_Suppressed = False
0412 bool_Accepted = False
0413 bool_Ignored = False
0414 bool_Quoted_Text = False
0415 bool_Footnote = False
0416 bool_Check_FN_Quote = False
0417 bool_Invalid_Cognate = False
0418 bool_In_Author = False
0419 bool_In_HTML_Tag = False
0420 i = InStr(i, strObject_Text, strKeyWord)
0421 The_Word_Checker = ""
0422 If i > 0 Then
0423 Link_OK = True
0424 i = i + 2
0425 Else
0426 Link_OK = False
0427 End If
0428 If Link_OK = True Then
0429 j = FindWordEnd(strObject_Text, i + Len(strKeyWord) - 2, "]")
0430 If WordFound = "Yes" Then '"WordFound" is a global variable set in FindWordEnd
0431 The_Word_OK = True
0432 Else
0433 The_Word_OK = False
0434 End If
0435 k = FindWord(strObject_Text, i) 'Find Start of word (may be pre-fixed)
0436 If k > 1 Then
0437 'Check no Bracket at start ... if so, probably already bagged! [Ie. already has tags]
0438 If Mid(strObject_Text, k, 1) = "[" Then
0439 The_Word_OK = False
0440 End If
0441 End If
0442 Suppress_Reference = False
0443 Replace_Reference = False
0444 Ignore_Reference = False
0445 End If
0446 If Link_OK = True Then
0447 'Check for Author's name ...
0448 If k > 20 Then
0449 iCheck_Start = k - 20
0450 Else
0451 iCheck_Start = 1
0452 End If
0453 iCheck_End = j + 20
0454 OK = Check_If_In_Container(strObject_Text, "+A", (j + k) / 2, "A+", iCheck_Start, iCheck_End)
0455 If OK <> "No" Then 'In an Author Name
0456 bool_In_Author = True
0457 Link_OK = False
0458 The_Word = Mid(strObject_Text, k, j - k)
0459 End If
0460 'Check if in HTML Tag ...
0461 If k > 40 Then
0462 iCheck_Start = k - 40
0463 Else
0464 iCheck_Start = 1
0465 End If
0466 iCheck_End = j + 40
0467 OK = Check_If_In_Container(strObject_Text, "<A", (j + k) / 2, "</A>", iCheck_Start, iCheck_End)
0468 If OK <> "No" Then 'In an Author Name
0469 bool_In_HTML_Tag = True
0470 Link_OK = False
0471 The_Word = Mid(strObject_Text, k, j - k)
0472 End If
0473 End If
0474 If Link_OK = True Then
0475 If The_Word_OK = True Then 'Ie. the Word has no tags already
0476 The_Word = Mid(strObject_Text, k, j - k)
0477 'Need to check for excluded Cognates
0478 If Invalid_Cognates = True Then
0479 If j - k < iAfter_Max Then
0480 iAfter = iAfter_Max
0481 Else
0482 iAfter = j - k
0483 End If
0484 If iBefore_Max > 0 Then
0485 If k > iBefore_Max Then
0486 iBefore = k - iBefore_Max
0487 Else
0488 iBefore = 1
0489 End If
0490 Else
0491 iBefore = k
0492 End If
0493 The_Word_Checker = Mid(strObject_Text, iBefore, j - iBefore + iAfter)
0494 OK = Spot_Invalid_Cognates(The_Word_Checker, Cognate_Array())
0495 Else
0496 OK = "OK"
0497 End If
0498 If OK <> "OK" Then
0499 Link_OK = False
0500 bool_Invalid_Cognate = True
0501 The_Word_OK = False
0502 Else
0503 If Confirming_Flag = "All" Or Confirming_Flag = "New" Then
0504 'Ask if we want this link
0505 If k > 100 Then
0506 strQuestion = Mid(strObject_Text, k - 100, 200)
0507 Else
0508 strQuestion = Left(strObject_Text, 200)
0509 End If
0510 strQuestion = strKeyWord & ": Accept this link?""... " & Chr$(10) & strTitle & ": " & iObject_ID & " : " & rsObject.Fields(1) & Chr$(10) & strQuestion & "..."""
0511 If (iCounter = 1 And Updating_Run_Notes = True) Or (iCounter <> 1 And Updating_Run_Others = True) Then
0512 Msg_Response = MsgBox(strQuestion, vbYesNoCancel + vbDefaultButton1)
0513 Select Case Msg_Response
0514 Case vbNo
0515 Suppress_Reference = True
0516 OK = DebugPrint(Suppress_Debug_Printing, strTitle & "; " & iObject_ID & "; " & The_Word & "; " & k & "; To be suppressed")
0517 bool_Suppressed = True
0518 Case vbYes
0519 OK = DebugPrint(Suppress_Debug_Printing, strTitle & "; " & iObject_ID & "; " & The_Word & "; " & k & "; Accepted")
0520 bool_Accepted = True
0521 Object_Exclude = False
0522 Case vbCancel
0523 OK = DebugPrint(Suppress_Debug_Printing, strTitle & "; " & iObject_ID & "; " & The_Word & "; " & k & "; Ignored")
0524 Ignore_Reference = True
0525 bool_Ignored = True
0526 End Select
0527 Else
0528 Object_Exclude = False
0529 OK = DebugPrint(Suppress_Debug_Printing, strTitle & "; " & iObject_ID & "; " & The_Word & "; " & k & "; Listed")
0530 If iCounter = 1 Then
0531 New_Links_Unprocessed_Notes = New_Links_Unprocessed_Notes + 1
0532 Else
0533 New_Links_Unprocessed_Others = New_Links_Unprocessed_Others + 1
0534 End If
0535 End If
0536 Else
0537 Object_Exclude = False
0538 OK = DebugPrint(Suppress_Debug_Printing, strTitle & "; " & iObject_ID & "; " & The_Word & "; " & k & "; Listed")
0539 If iCounter = 1 Then
0540 New_Links_Unprocessed_Notes = New_Links_Unprocessed_Notes + 1
0541 Else
0542 New_Links_Unprocessed_Others = New_Links_Unprocessed_Others + 1
0543 End If
0544 End If
0545 End If
0546 Else
0547 'The word has tags '***********************************
0548 The_Word = Mid(strObject_Text, k, j - k + 4)
0549 'First check if excluded Cognate ...
0550 If Invalid_Cognates = True Then
0551 If j - k < iAfter_Max Then
0552 iAfter = iAfter_Max
0553 Else
0554 iAfter = j - k
0555 End If
0556 If iBefore_Max > 0 Then
0557 If k > iBefore_Max Then
0558 iBefore = k - iBefore_Max
0559 Else
0560 iBefore = 1
0561 End If
0562 Else
0563 iBefore = k
0564 End If
0565 The_Word_Checker = Mid(strObject_Text, iBefore, j - iBefore + iAfter + 4) 'This isn't really necessary as far as "after" is concerned
0566 OK = Spot_Invalid_Cognates(The_Word_Checker, Cognate_Array())
0567 Else
0568 OK = "OK"
0569 End If
0570 If OK <> "OK" Then
0571 Link_OK = False
0572 bool_Invalid_Cognate = True
0573 Else
0574 If Right(The_Word, 4) = "+XX+" Then
0575 OK = DebugPrint(Suppress_Debug_Printing, strTitle & "; " & iObject_ID & "; " & The_Word & "; " & k & "; Suppressed Reference")
0576 Suppress_Reference = True
0577 bool_Suppressed = True
0578 bool_Check_FN_Quote = True
0579 Else
0580 If Confirming_Flag = "All" Then
0581 'Ask if we want to suppress this link
0582 Note_Tag1 = "+N" & iKeyWord_ID & "N+"
0583 Note_Tag2 = "++" & iKeyWord_ID & "++"
0584 If InStr(The_Word, " ") > 0 Then
0585 Note_Tag1 = "]" & Note_Tag1
0586 Note_Tag2 = "]" & Note_Tag2
0587 End If
0588 If (Mid(strObject_Text, j, Len(Note_Tag1)) = Note_Tag1) Or (Mid(strObject_Text, j, Len(Note_Tag2)) = Note_Tag2) Then
0589 'But don't ask if link isn't of the right form
0590 If k > 100 Then
0591 strQuestion = Mid(strObject_Text, k - 100, 200)
0592 Else
0593 strQuestion = Left(strObject_Text, 200)
0594 End If
0595 strQuestion = strKeyWord & ": Remove & Suppress this link?""... " & Chr$(10) & strTitle & ": " & iObject_ID & " : " & rsObject.Fields(1) & Chr$(10) & strQuestion & "..."""
0596 If (iCounter = 1 And Updating_Run_Notes = True) Or (iCounter <> 1 And Updating_Run_Others = True) Then
0597 If MsgBox(strQuestion, vbYesNo + vbDefaultButton2) = vbYes Then
0598 Suppress_Reference = True
0599 Replace_Reference = True
0600 The_Word_OK = True
0601 OK = DebugPrint(Suppress_Debug_Printing, strTitle & "; " & iObject_ID & "; " & The_Word & "; " & k & "; Existing link To be suppressed")
0602 bool_Suppressed = True
0603 bool_Check_FN_Quote = True
0604 Else
0605 OK = DebugPrint(Suppress_Debug_Printing, strTitle & "; " & iObject_ID & "; " & The_Word & "; " & k & "; Existing link Accepted")
0606 Object_Exclude = False
0607 bool_Accepted = True
0608 bool_Check_FN_Quote = True
0609 End If
0610 Else
0611 OK = DebugPrint(Suppress_Debug_Printing, strTitle & "; " & iObject_ID & "; " & The_Word & "; " & k & "; Already linked")
0612 Object_Exclude = False
0613 bool_Already_Linked = True
0614 End If
0615 Else
0616 OK = DebugPrint(Suppress_Debug_Printing, strTitle & "; " & iObject_ID & "; " & The_Word & "; " & k & "; Already linked")
0617 Object_Exclude = False
0618 bool_Already_Linked = True
0619 bool_Check_FN_Quote = True
0620 End If
0621 Else
0622 If j - k < iAfter_Max Then
0623 iAfter = iAfter_Max
0624 Else
0625 iAfter = j - k
0626 End If
0627 If iBefore_Max > 0 Then
0628 If k > iBefore_Max Then
0629 iBefore = k - iBefore_Max
0630 Else
0631 iBefore = 1
0632 End If
0633 Else
0634 iBefore = k
0635 End If
0636 The_Word_Checker = Mid(strObject_Text, iBefore, j - iBefore + iAfter)
0637 OK = Spot_Invalid_Cognates(The_Word_Checker, Cognate_Array())
0638 If OK = "OK" Then
0639 OK = DebugPrint(Suppress_Debug_Printing, strTitle & "; " & iObject_ID & "; " & The_Word & "; " & k & "; Already linked")
0640 bool_Already_Linked = True
0641 bool_Check_FN_Quote = True
0642 Object_Exclude = False
0643 Else
0644 OK = DebugPrint(Suppress_Debug_Printing, strTitle & "; " & iObject_ID & "; " & The_Word & "; " & k & "; Already linked, but Invalid Cognate")
0645 bool_Already_Linked = True
0646 bool_Invalid_Cognate = True
0647 bool_Check_FN_Quote = False
0648 End If
0649 End If
0650 End If
0651 'End of checking tagged word... ****************************
0652 End If
0653 End If
0654 If bool_Invalid_Cognate = False Then
0655 If The_Word_OK = False And bool_Check_FN_Quote = True Then
0656 OK = Check_If_In_Container(strObject_Text, "|Colour_2|", (j + k) / 2, "|Colour_R|")
0657 If OK <> "No" Then 'In a quotation
0658 bool_Quoted_Text = True
0659 End If
0660 OK = Check_If_In_Container(strObject_Text, "++FN", (j + k) / 2, "++")
0661 If OK <> "No" Then 'In a footnote
0662 bool_Footnote = True
0663 End If
0664 End If
0665 If The_Word_OK = True Then
0666 'Check if in quoted text
0667 OK = Check_If_In_Container(strObject_Text, "|Colour_2|", (j + k) / 2, "|Colour_R|")
0668 If OK <> "No" Then 'In a quotation
0669 Own_Text = False
0670 OK = DebugPrint(Suppress_Debug_Printing, strTitle & "; " & iObject_ID & "; " & The_Word & "; " & k & "; In quoted text")
0671 bool_Quoted_Text = True
0672 Else
0673 Own_Text = True
0674 End If
0675 'Find if in Footnote
0676 In_Footnote = False
0677 OK = Check_If_In_Container(strObject_Text, "++FN", (j + k) / 2, "++")
0678 If OK <> "No" Then 'In a footnote
0679 In_Footnote = True
0680 OK = DebugPrint(Suppress_Debug_Printing, strTitle & "; " & iObject_ID & "; " & The_Word & "; " & k & "; In Footnote")
0681 bool_Footnote = True
0682 Else
0683 In_Footnote = False
0684 End If
0685 If (In_Footnote = True) Or (iCounter = 5) Then 'Book comments require +NnnnN+ format
0686 'Add +NnnnN+
0687 Note_Tag = "+N" & iKeyWord_ID & "N+"
0688 Else
0689 'Add ++nnn++
0690 Note_Tag = "++" & iKeyWord_ID & "++"
0691 End If
0692 End If
0693 If The_Word_OK = True Then
0694 If iCounter = 1 And Updating_Run_Notes = True Then 'Notes only! Write out to Notes_To_Regen_Temp if it doesn't already exist
0695 strQuery = "SELECT * FROM Notes_To_Regen_Temp WHERE Note_ID=" & iObject_ID & ";"
0696 Set rsNotes_To_Regen_Temp = CurrentDb.OpenRecordset(strQuery)
0697 If rsNotes_To_Regen_Temp.EOF Then
0698 rsNotes_To_Regen_Temp.AddNew
0699 rsNotes_To_Regen_Temp.Fields(0) = iObject_ID
0700 rsNotes_To_Regen_Temp.Fields(1) = Now()
0701 rsNotes_To_Regen_Temp.Update
0702 End If
0703 End If
0704 If (iCounter = 4 Or iCounter = 5) And Updating_Run_Others = True Then 'Books only!
0705 strQuery = "SELECT * FROM Books_To_Regen WHERE Book_ID=" & iObject_ID & ";"
0706 Set rsBooks_To_Regen = CurrentDb.OpenRecordset(strQuery)
0707 If rsBooks_To_Regen.EOF Then
0708 rsBooks_To_Regen.AddNew
0709 rsBooks_To_Regen.Fields(0) = iObject_ID
0710 rsBooks_To_Regen.Update
0711 End If
0712 End If
0713 'Update the Text (but not, yet, the actual object
0714 Update_Object = True
0715 If Suppress_Reference = True Then
0716 If Replace_Reference = True Then
0717 'Need to remove brackets ... TO BE SUPPLIED!
0718 If InStr(The_Word, " ") > 0 Then
0719 'Need to remove brackets
0720 If k > 5 Then
0721 OK = DebugPrint(Suppress_Debug_Printing, Mid(strObject_Text, k, j - k + 20))
0722 strObject_Text = Left(strObject_Text, k - 5) & Replace(Replace(Mid(strObject_Text, k - 4, j - k + 5), "[", ""), "]", "") & Mid(strObject_Text, j + 1)
0723 OK = DebugPrint(Suppress_Debug_Printing, Mid(strObject_Text, k, j - k + 20))
0724 Else
0725 OK = DebugPrint(Suppress_Debug_Printing, Left(strObject_Text, j + 20))
0726 strObject_Text = Replace(Replace(Left(strObject_Text, j + 1) & Mid(strObject_Text, j + 2), "[", ""), "]", "")
0727 OK = DebugPrint(Suppress_Debug_Printing, Left(strObject_Text, j + 20))
0728 End If
0729 j = j - 1
0730 End If
0731 strObject_Text = Left(strObject_Text, j - 1) & "+XX+" & Mid(strObject_Text, j + Len(Note_Tag))
0732 OK = DebugPrint(Suppress_Debug_Printing, Mid(strObject_Text, k, j - k + 20))
0733 Else
0734 strObject_Text = Left(strObject_Text, j - 1) & "+XX+" & Mid(strObject_Text, j)
0735 End If
0736 Else
0737 If Ignore_Reference = False Then
0738 If InStr(The_Word, " ") > 0 Then
0739 'Need to bracket the KeyWord
0740 Note_Tag = "[" & The_Word & "]" & Note_Tag
0741 strObject_Text = Left(strObject_Text, k - 1) & Note_Tag & Mid(strObject_Text, j)
0742 i = i + 1
0743 Else
0744 strObject_Text = Left(strObject_Text, j - 1) & Note_Tag & Mid(strObject_Text, j)
0745 End If
0746 End If
0747 End If
0748 iUpdates = iUpdates + 1
0749 End If
0750 End If
0751 End If
0752 If i > 0 Then
0753 If The_Word_Checker = "" Then
0754 The_Word_Checker = The_Word
0755 End If
0756 On Error Resume Next 'Fudge ...
0757 'Output Auto_Reference_Notes_Actions row
0758 rsAuto_Reference_Notes_Actions.AddNew
0759 rsAuto_Reference_Notes_Actions.Fields(0) = iKeyWord_ID
0760 rsAuto_Reference_Notes_Actions.Fields(1) = strKeyWord
0761 rsAuto_Reference_Notes_Actions.Fields(2) = strTitle
0762 rsAuto_Reference_Notes_Actions.Fields(3) = iObject_ID
0763 rsAuto_Reference_Notes_Actions.Fields(4) = The_Word_Checker
0764 rsAuto_Reference_Notes_Actions.Fields(5) = k
0765 rsAuto_Reference_Notes_Actions.Fields(6) = Now()
0766 rsAuto_Reference_Notes_Actions.Fields(7) = bool_Already_Linked
0767 rsAuto_Reference_Notes_Actions.Fields(8) = bool_Suppressed
0768 rsAuto_Reference_Notes_Actions.Fields(9) = bool_Accepted
0769 rsAuto_Reference_Notes_Actions.Fields(10) = bool_Ignored
0770 rsAuto_Reference_Notes_Actions.Fields(11) = bool_Quoted_Text
0771 rsAuto_Reference_Notes_Actions.Fields(12) = bool_Footnote
0772 rsAuto_Reference_Notes_Actions.Fields(13) = bool_In_Author
0773 rsAuto_Reference_Notes_Actions.Fields(14) = bool_In_HTML_Tag
0774 rsAuto_Reference_Notes_Actions.Fields(15) = bool_Invalid_Cognate
0775 rsAuto_Reference_Notes_Actions.Update
0776 On Error GoTo Error_Found
0777 End If
0778 Loop
0779 'End of the loop to interrogate a particular Object
0780 '************************************************************************************
0781 End If
0782 'Update the Test Note
0783 If Suppress_Reference = False And Object_Exclude = False Then
0784 Select Case iCounter
0785 Case 0 'Authors
0786 strTestNote = strTestNote & "|1|+" & Object_Marker & rsObject.Fields(1) & Object_Marker & "+"
0787 Case 1 'Notes
0788 strTestNote = strTestNote & "|1|[" & rsObject.Fields(1) & "]++" & iObject_ID & "++"
0789 Case Else
0790 strTestNote = strTestNote & "|1|+" & Object_Marker & iObject_ID & Object_Marker & "+"
0791 If Object_Read = True Then
0792 strTestNote = strTestNote & " <b>***Read***</b>"
0793 End If
0794 End Select
0795 End If
0796 If Update_Object = True And Exclude = False Then
0797 'Update the Object
0798 If (iCounter = 1 And Updating_Run_Notes = True) Then
0799 rsObject.Edit
0800 rsObject.Fields(2) = strObject_Text
0801 rsObject.Update
0802 If rsObject.Fields(4) & "" <> "Temp" Then
0803 'Need to update the latest Archive Note as well, to stop creating a needless Archive
0804 strQuery = "SELECT Notes_Archive.ID, Notes_Archive.Timestamp, Notes_Archive.Item_Text FROM Notes_Archive WHERE (((Notes_Archive.ID) = " & iObject_ID & ")) ORDER BY Notes_Archive.Timestamp DESC;"
0805 Set rsNotes_Archive = CurrentDb.OpenRecordset(strQuery)
0806 If Not rsNotes_Archive.EOF Then
0807 rsNotes_Archive.MoveFirst
0808 rsNotes_Archive.Edit
0809 rsNotes_Archive.Fields(2) = strObject_Text
0810 rsNotes_Archive.Update
0811 End If
0812 Set rsNotes_Archive = Nothing
0813 End If
0814 End If
0815 If ((iCounter = 0 Or (iCounter > 1 And iCounter < 6)) And Updating_Run_Others = True) Then
0816 rsObject.Edit
0817 rsObject.Fields(2) = strObject_Text
0818 rsObject.Update
0819 End If
0820 End If
0821 End If
0822 'Check if we want to continue
0823 StopRun = False
0824 If strQuestion & "" <> "" Then
0825 If (iCounter = 1 And Updating_Run_Notes = True) Or (iCounter <> 1 And Updating_Run_Others = True) Then
0826 iQuestions = iQuestions + 1
0827 If iQuestions > iMax_Questions Then
0828 strQuestion = "Maximum of " & iMax_Questions & " exceeded. Continue for another " & iMax_Questions & " questions (Reply ""Yes"")" & " or terminate? (Reply ""No"")"
0829 Msg_Response = MsgBox(strQuestion, vbYesNo + vbDefaultButton1)
0830 If Msg_Response = vbNo Then
0831 rsObject.MoveLast
0832 StopRun = True
0833 iCounter = 8
0834 Else
0835 iQuestions = 0
0836 End If
0837 End If
0838 End If
0839 End If
0840 strQuestion = ""
0841 rsObject.MoveNext
0842 'Object_Exclude = Exclude 'I don't think this is correct ... all objects should be set to "exclude" until accepted
0843 Object_Exclude = True
0844 If Not rsObject.EOF Then
0845 iObject_ID = rsObject.Fields(0)
0846 If Object_Marker = "B" Or Object_Marker = "P" Then
0847 Object_Read = rsObject.Fields(4)
0848 Else
0849 Object_Read = False
0850 End If
0851 End If
0852 Loop
0853 'Update the Test Note
0854 strTestNote = strTestNote & "|99|"
0855 End If
0856 Next iCounter
0857 End If
0858 strTestNote = strTestNote & "|..|"
0859 'Update last run date for this key-word
0860 strQuery = "SELECT Note_Alternates.Last_Auto_Link_Run, Note_Alternates.Last_Auto_Link_Notes, Note_Alternates.Last_Auto_Link_Others, Note_Alternates.New_Links_Unprocessed_Notes, Note_Alternates.New_Links_Unprocessed_Other FROM Note_Alternates WHERE (((Note_Alternates.ID)=" & iKeyWord_ID & ") AND ((Note_Alternates.Item_Alt_Title)=[Note_Alternates]![Item_Title]));"
0861 Set rsKeyWords_Update = CurrentDb.OpenRecordset(strQuery)
0862 rsKeyWords_Update.MoveFirst
0863 rsKeyWords_Update.Edit
0864 rsKeyWords_Update.Fields(0) = Now()
0865 If Updating_Run_Notes = True Then
0866 rsKeyWords_Update.Fields(1) = Now()
0867 End If
0868 If Updating_Run_Others = True Then
0869 rsKeyWords_Update.Fields(2) = Now()
0870 End If
0871 rsKeyWords_Update.Fields(3) = New_Links_Unprocessed_Notes
0872 rsKeyWords_Update.Fields(4) = New_Links_Unprocessed_Others
0873 rsKeyWords_Update.Update
0874 'Next Key Word
0875 If StopRun = True Then
0876 rsKeyWords.MoveLast
0877 End If
0878 rsKeyWords.MoveNext
0879 Set rsCognate_Array = Nothing
0880 If Invalid_Cognates = True Then
0881 For i = LBound(Cognate_Array) To UBound(Cognate_Array)
0882 Cognate_Array(i) = Null
0883 Next i
0884 End If
0885Loop
0886'Update the Test Note
0887If strCognates = "xxxx" Then
0888 strCognates = ""
0889End If
0890strTestNote = "<h2>[" & strHeader & "]++++</h2>" & IIf(strCognates = "", "", "<h3>(Cognates: " & strCognates & ")</h3>") & "<h3>(Links Page)</h3>" & strTestNote & "|II|"
0891'Add the dates ...
0892strTestNote = strTestNote & "<br><hr><p><b>Latest update for Notes:</b> " & IIf(rsKeyWords_Update.Fields(1) & "" = "", "None", rsKeyWords_Update.Fields(1)) & "</p>"
0893strTestNote = strTestNote & "<p><b>Latest update for Other Objects:</b> " & IIf(rsKeyWords_Update.Fields(2) & "" = "", "None", rsKeyWords_Update.Fields(2)) & "</p>"
0894'Add the Auto_Ref_Notes_Stats_Summary & Auto_Ref_Notes_Stats_Detailed tables of usage
0895strTestNote = strTestNote & "<hr><p><b><u>Summary of Key Words Found</b></u></p>"
0896 OK = Functor_21(4, strTable)
0897strTestNote = strTestNote & strTable & "<br><p><b><u>Detailed Summary of Key Words Found</b></u></p>"
0898 OK = Functor_21(5, strTable)
0899strTestNote = strTestNote & strTable
0900'Update the Test Note
0901 strQuery = "SELECT Notes.ID, Notes.Item_Title, Notes.Note_Group, Notes.Status, Notes.Item_Text FROM Notes WHERE Notes.ID = 874;"
0902Set rsTestNote = CurrentDb.OpenRecordset(strQuery)
0903rsTestNote.MoveFirst
0904rsTestNote.Edit
0905rsTestNote.Fields(3) = "Temp"
0906rsTestNote.Fields(4) = strTestNote
0907rsTestNote.Update
0908Set rsNotes_To_Regen = Nothing
0909'Output the Test Note
0910 strQuery = "DELETE * FROM Notes_To_Regen;"
0911DoCmd.RunSQL (strQuery)
0912 strQuery = "SELECT * FROM Notes_To_Regen;"
0913Set rsNotes_To_Regen = CurrentDb.OpenRecordset(strQuery)
0914rsNotes_To_Regen.AddNew
0915rsNotes_To_Regen.Fields(0) = 874
0916rsNotes_To_Regen.Fields(1) = Now()
0917rsNotes_To_Regen.Update
0918Archive_Notes_Now = "No"
0919Regenerate_the_Links = "No"
0920Regen_Notes_Only = "Yes"
0921 CreateNotesWebPages
0922TestFile = TheoWebsiteRoot & "\Notes\Notes_8\Notes_874.htm"
0923 strQuery = "SELECT Notes.ID, Notes.Item_Title, Notes.Note_Group, Notes.Status, Notes.Item_Text FROM Notes WHERE Notes.ID = " & iKeyWord_ID & ";"
0924Set rsObject = CurrentDb.OpenRecordset(strQuery)
0925rsObject.MoveFirst
0926DirectoryName = TheoWebsiteRoot & "\"
0927If rsObject.Fields(2) = 10 Then 'Supervisions
0928 DirectoryName = DirectoryName & "Secure_Jen\"
0929Else
0930 DirectoryName = DirectoryName & "Notes\"
0931End If
0932DirectoryName = DirectoryName & "Notes_" & Val(Mid(iKeyWord_ID + 10000, 2, 2)) & "\"
0933FileName = "Notes_" & iKeyWord_ID & "_Links.htm"
0934'Copy the Test Note to the relevant Notes directory
0935If Dir(DirectoryName & FileName) <> "" Then 'If we already have a file in the transfer directory, then zap it
0936 Kill DirectoryName & FileName
0937End If
0938fs.CopyFile TestFile, DirectoryName & FileName
0939'Copy to Transfer
0940 OK = CopyToTransfer(DirectoryName, FileName)
0941'Clear the Notes_To_Regen table ...
0942 strQuery = "DELETE * FROM Notes_To_Regen;"
0943DoCmd.RunSQL (strQuery)
0944'Copy Notes_To_Regen_Temp to Notes_To_Regen ...
0945 strQuery = "INSERT INTO Notes_To_Regen ( Note_ID, [Timestamp] ) SELECT Notes_To_Regen_Temp.Note_ID, Notes_To_Regen_Temp.Timestamp FROM Notes_To_Regen_Temp;"
0946DoCmd.RunSQL (strQuery)
0947'Tidy Up
0948Set rsKeyWords = Nothing
0949Set rsObject = Nothing
0950Set rsNotes_To_Regen = Nothing
0951Set rsNotes_To_Regen_Temp = Nothing
0952Set rsBooks_To_Regen = Nothing
0953Set rsTestNote = Nothing
0954Set rsKeyWords_Update = Nothing
0955Set rsAuto_Reference_Notes_Actions = Nothing
0956Set rsCognate_Array = Nothing
0957Set fs = Nothing
0958 OK = DebugPrint(Suppress_Debug_Printing, iUpdates & " changes made for KeyWord = " & strKeyWord & ".")
0959If Non_Updating_Regen = False Then
0960 Duration = Round((Now() - RunStartTime) * 24 * 60, 1)
0961 strMsg = Now() & " - Automatic Note Linkages Completed in "
0962 If Duration < 1 Then
0963 Duration = Round((Now() - RunStartTime) * 24 * 60 * 60)
0964 strMsg = strMsg & Duration & " seconds. "
0965 Else
0966 strMsg = strMsg & Duration & " minutes. "
0967 End If
0968 strMsg = strMsg & iUpdates & " changes made."
0969 Debug.Print strMsg
0970 MsgBox strMsg, vbOKOnly, "Automatic Note Linkages"
0971End If
0972Exit Sub
0973Error_Found:
0974Stop
0975End Sub

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


Source Code of: Backup_Prune_Ctrl
Procedure Type: Public Sub
Module: Backups
Lines of Code: 65
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Backup_Prune_Ctrl()
0002Dim OK As String
0003Dim Start_Time As Date
0004Dim rst As Recordset
0005Dim db As Database
0006Dim Run_Duration As Single
0007Dim Run_Duration_Text As String
0008Dim strMsg As String
0009Dim Backup_Depth As Integer
0010Dim RecordsPrior As Long
0011Dim RecordsPost As Long
0012Dim Backup_Database As String
0013Dim Directory_Only As Boolean
0014Dim Directory_Timestamp_Local As Date
0015Set db = CurrentDb
0016Start_Time = Now()
0017Files_Processed = 0
0018Files_Logged = 0
0019Directories_Logged = 0
0020Backup_Depth = 0
0021Backup_Database = "C:\Theo's Files\Birkbeck\Backups_Prune"
0022Backup_Source_Root_Directory = "D:\"
0023'Parameter ...
0024Directory_Only = False
0025 DoCmd.RunSQL ("DELETE Full_Backup_Directory_Structure_Temp.* FROM Full_Backup_Directory_Structure_Temp;")
0026 DoCmd.RunSQL ("DELETE Full_Backup_Site_Map_Temp.* FROM Full_Backup_Site_Map_Temp;")
0027strMsg = "Backup: Pruning Parameters are:- " & Chr$(10)
0028strMsg = strMsg & Chr$(10) & "Backup_Source_Root_Directory = " & Backup_Source_Root_Directory
0029strMsg = strMsg & Chr$(10) & "Record Directory Only = " & Directory_Only
0030strMsg = strMsg & Chr$(10) & Chr$(10) & "Proceed?"
0031If MsgBox(strMsg, vbYesNo) = vbNo Then
0032 End
0033End If
0034 Set rst = db.OpenRecordset("SELECT Max(Full_Backup_Directory_Structure.Directory_ID) AS MaxOfDirectory_ID FROM Full_Backup_Directory_Structure;")
0035If Not rst.EOF Then
0036 rst.MoveFirst
0037 Directory_ID = rst.Fields(0)
0038Else
0039 Directory_ID = 0
0040End If
0041Set rst = Nothing
0042Directory_Timestamp_Local = 0
0043Time_Start_Old = Now()
0044 OK = Backup_Prune_Scurry(Backup_Source_Root_Directory, Directory_Timestamp_Local, Backup_Depth, Backup_Database, Directory_Only)
0045automatic_processing = "Yes"
0046 Compact_Repair (Backup_Database)
0047'Flag_For_Deletion
0048'Zap_Duplicate_Files
0049 Set rst = db.OpenRecordset("SELECT Count(Full_Backup_Site_Map_Temp.File_Name) AS CountOfFile_Name FROM Full_Backup_Site_Map_Temp;")
0050rst.MoveFirst
0051RecordsPost = rst.Fields(0)
0052Set rst = Nothing
0053Run_Duration = Now() - Start_Time
0054Run_Duration = Run_Duration * 24
0055If Run_Duration < 1 Then
0056 Run_Duration_Text = Round(Run_Duration * 60, 2) & " minutes"
0057Else
0058 Run_Duration_Text = Round(Run_Duration, 2) & " hours"
0059End If
0060strMsg = "Backup System Pruning completed at " & Now() & " in " & Run_Duration_Text & "."
0061strMsg = strMsg & Chr$(10) & "Files processed = " & Files_Processed & "."
0062strMsg = strMsg & Chr$(10) & "Directories Logged = " & Directories_Logged & ". Records Prior = " & RecordsPrior & ", Records Post = " & RecordsPost & ", difference = " & RecordsPost - RecordsPrior & "."
0063Debug.Print strMsg
0064MsgBox (strMsg)
0065End Sub

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


Source Code of: Check_If_In_Container
Procedure Type: Public Function
Module: Testing
Lines of Code: 31
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Check_If_In_Container(strObject_Text, Container_Start, Keyword_Location, Container_End, Optional iStart, Optional iEnd)
0002Dim i As Long
0003Dim j As Long
0004Dim iStart_Local As Long
0005Dim iEnd_Local As Long
0006If IsMissing(iStart) Then
0007 iStart_Local = 1
0008Else
0009 iStart_Local = iStart
0010End If
0011If IsMissing(iEnd) Then
0012 iEnd_Local = Len(strObject_Text)
0013Else
0014 iEnd_Local = iEnd
0015End If
0016Check_If_In_Container = "No"
0017i = InStr(iStart_Local, strObject_Text, Container_Start)
0018Do While i > 0 And i < iEnd_Local
0019 j = InStr(i + 1, strObject_Text, Container_End)
0020 If j = 0 Then 'Data Bug - exit
0021 Exit Function
0022 Else
0023 If Keyword_Location > i And Keyword_Location < j Then
0024 Check_If_In_Container = "Yes"
0025 Exit Function
0026 Else
0027 i = InStr(j + 1, strObject_Text, Container_Start)
0028 End If
0029 End If
0030Loop
0031End Function

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


Source Code of: Code_Archive_Prune
Procedure Type: Public Sub
Module: Documentation
Lines of Code: 26
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Code_Archive_Prune()
0002Dim rsTableToRead As Recordset
0003Dim strQuery As String
0004Dim PN_Saved As String
0005Dim Code_Saved As String
0006 strQuery = "SELECT Code_Archive_Table.Procedure_Name, Code_Archive_Table.Code FROM Code_Archive_Table ORDER BY Code_Archive_Table.Procedure_Name, Code_Archive_Table.Archive_Date;"
0007Set rsTableToRead = CurrentDb.OpenRecordset(strQuery)
0008rsTableToRead.MoveFirst
0009PN_Saved = ""
0010Code_Saved = ""
0011Do Until rsTableToRead.EOF
0012 If rsTableToRead.Fields(0) = PN_Saved Then
0013 If Code_Saved = rsTableToRead.Fields(1) Then
0014 rsTableToRead.Delete
0015 Else
0016 Code_Saved = rsTableToRead.Fields(1)
0017 End If
0018 Else
0019 PN_Saved = rsTableToRead.Fields(0)
0020 Code_Saved = rsTableToRead.Fields(1)
0021 End If
0022 rsTableToRead.MoveNext
0023Loop
0024 Archive_Xtab_Page
0025 Archive_Xtab_Page ("X")
0026End Sub

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


Source Code of: Zap_Duplicate_Files
Procedure Type: Public Sub
Module: Backups
Lines of Code: 61
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Zap_Duplicate_Files()
0002Dim rst2 As Recordset
0003Dim db As Database
0004Dim File_To_Zap As String
0005Dim Files_Zapped As Long
0006Dim strMsg As String
0007Dim Run_Duration As Single
0008Dim Run_Duration_Text As String
0009Dim Start_Time As Date
0010Dim Record_Count As Long
0011Dim Error_Count As Long
0012Dim Not_Found As Long
0013Start_Time = Now()
0014Record_Count = 0
0015Files_Zapped = 0
0016Error_Count = 0
0017Not_Found = 0
0018Set db = CurrentDb
0019 Set rst2 = db.OpenRecordset("SELECT * FROM Full_Backup_Site_Map_Temp_Delete_Control WHERE Deleted = No ORDER BY Directory, File_Name;")
0020rst2.MoveFirst
0021Do Until rst2.EOF
0022 Record_Count = Record_Count + 1
0023 File_To_Zap = rst2.Fields(0) & rst2.Fields(1)
0024 On Error Resume Next
0025 If Dir(File_To_Zap) <> "" Then
0026 Kill (File_To_Zap)
0027 If Err.Number <> 0 Then
0028 Debug.Print Now(), Err.Number, Err.Description, File_To_Zap
0029 Err.Clear
0030 Error_Count = Error_Count + 1
0031 rst2.Edit
0032 rst2.Fields(4) = True
0033 rst2.Update
0034 Else
0035 Files_Zapped = Files_Zapped + 1
0036 rst2.Edit
0037 rst2.Fields(3) = True
0038 rst2.Fields(4) = False
0039 rst2.Update
0040 End If
0041 Else
0042 Debug.Print Now(), "Not Found", File_To_Zap
0043 Not_Found = Not_Found + 1
0044 End If
0045 rst2.MoveNext
0046Loop
0047Set rst2 = Nothing
0048Run_Duration = Now() - Start_Time
0049Run_Duration = Run_Duration * 24
0050If Run_Duration < 1 Then
0051 Run_Duration_Text = Round(Run_Duration * 60, 2) & " minutes"
0052Else
0053 Run_Duration_Text = Round(Run_Duration, 2) & " hours"
0054End If
0055strMsg = "File Deletion completed at " & Now() & " in " & Run_Duration_Text & "."
0056strMsg = strMsg & Chr$(10) & "Records Read = " & Record_Count & ". Files deleted = " & Files_Zapped & ". Failed deletions = " & Error_Count & ". Files not found = " & Not_Found & "."
0057Debug.Print strMsg
0058If automatic_processing <> "Yes" Then
0059 MsgBox (strMsg)
0060End If
0061End Sub

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