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

Notes_Text_FormatNumberedBulletsReference_BooksReference_Notes
Reference_PapersReplaceCodeWidthcheck.

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

Go to top of page



Source Code of: Notes_Text_Format
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 532
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Notes_Text_Format(NoteID, Note_Ref, strLine, Last_Changed_Timestamp As Long, Notes_Group_Name, Optional strPrintable)
0002Dim x As Long
0003Dim Y As Long
0004Dim z As Long
0005Dim xx As String
0006Dim iSuperscript As Integer
0007Dim iSection As Integer
0008Dim strControlQuery As String
0009Dim rsNoteType As Recordset
0010Dim rsSecure As Recordset
0011Dim rsLatestTimestamp As Recordset
0012Dim rsNoteID As Recordset
0013Dim rsFNCheck As Recordset
0014Dim strLink1 As String
0015Dim strLink2 As String
0016Dim iFootNoteID As Integer
0017Dim i As Long
0018Dim TheWord As String
0019Dim FootNoteTimestamp As Long
0020Dim strDirectory As String
0021Dim strPrintThisSuperscript As String
0022Dim No_FN As String
0023Dim FN_Start As Long
0024Dim FN_End As Long
0025Dim strQuery As String
0026Dim rst As Recordset
0027Dim rst2 As Recordset
0028Dim db As Database
0029Dim FN_Number_Used As String
0030Dim DudRef As String
0031Dim Ref_Type As String
0032Dim strRef As String
0033Dim iSuperscript_Display As Integer
0034Dim Footnote_Text As String
0035Dim sw As StopWatch
0036Dim sw2 As StopWatch
0037'Test_Flag = True
0038If Test_Flag = True Then
0039 Set sw = New StopWatch
0040 Set sw2 = New StopWatch
0041 sw.StartTimer
0042End If
0043If Test_Flag = True Then
0044 sw2.StartTimer
0045End If
0046If IsMissing(strPrintable) Then
0047 Cross_Reference_Table_Open = False
0048 Set rsCross_Reference_Table = Nothing
0049 OK = Zap_Cross_References("N", NoteID, Last_Changed_Timestamp)
0050 Ref_Type = "N"
0051Else
0052 Ref_Type = "X"
0053End If
0054If Test_Flag = True Then
0055 Debug.Print Now(); "Notes_Text_Format"; NoteID; Note_Ref; Last_Changed_Timestamp; sw2.EndTimer; "Milliseconds"; " Startup"
0056 sw2.StartTimer
0057End If
0058'Delete items from the In-sheet Footnotes table
0059Set db = CurrentDb
0060 strQuery = "Delete * From Note_Footnotes Where Note_Footnotes!Note_ID = " & NoteID & ";"
0061DoCmd.RunSQL (strQuery)
0062'Now get ready to insert rows to In-sheet Footnotes table
0063 strQuery = "Select * From Note_Footnotes Where Note_Footnotes!Note_ID = " & NoteID & ";"
0064Set rst = db.OpenRecordset(strQuery)
0065 strLine = ReplaceCode(strLine, Chr(13) & Chr(10), "<BR>")
0066 strLine = Remove_Dummy_Ref(strLine)
0067'Added 25/03/20: For "Aeon Comment" links to Abstract in Summary Task Lists ... hopefully it won't muck up other Notes!
0068If Not IsMissing(strPrintable) Then
0069 strLine = Replace(strLine, """../../", """../../../")
0070End If
0071'Create the notes links
0072x = 1
0073iSuperscript = 1
0074'Process In-sheet Footnotes
0075x = InStr(x, strLine, "++FN")
0076If x > 0 Then
0077 x = 1
0078 No_FN = "No"
0079 x = InStr(x, strLine, "++")
0080 Do Until (No_FN = "Yes" And x = 0)
0081 If x > 0 Then
0082 If Mid(strLine, x + 2, 2) = "FN" Then
0083 'In-page footnote
0084 FN_Start = x
0085 x = x + 1
0086 x = InStr(x, strLine, "++")
0087 If x > 0 Then
0088 FN_End = x + 1
0089 Footnote_Text = Mid(strLine, FN_Start + 4, FN_End - FN_Start - 5) & ""
0090 If Footnote_Text <> "" Then
0091 If Mid(strLine, FN_Start - 1, 1) = " " Then
0092 i = FindWord(strLine, FN_Start - 1, "]")
0093 Else
0094 i = FindWord(strLine, FN_Start, "]")
0095 End If
0096 'Add to table
0097 rst.AddNew
0098 rst.Fields(0) = NoteID
0099 rst.Fields(1) = iSuperscript
0100 rst.Fields(2) = Footnote_Text
0101 rst.Fields(3) = Now()
0102 rst.Update
0103 'Find if a duplicate FN
0104 Mark_Duplicate_Footnotes (NoteID)
0105 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)=" & NoteID & ") AND ((Note_Footnotes.FN_ID)=" & iSuperscript & "));")
0106 rsFNCheck.MoveFirst
0107 If rsFNCheck.Fields(1) <> rsFNCheck.Fields(2) Then
0108 iSuperscript_Display = rsFNCheck.Fields(2)
0109 Else
0110 iSuperscript_Display = iSuperscript
0111 End If
0112 Set rsFNCheck = Nothing
0113 strLink1 = "<U><A HREF=""#On-Page_Link_" & NoteID & "_" & iSuperscript_Display & """>"
0114 'strLink2 = "</A></U><SUB>" & iSuperscript & IIf(iSuperscript <> iSuperscript_Display, "=" & iSuperscript_Display, "") & "</SUB>" & "<a name=""On-Page_Return_" & NoteID & "_" & iSuperscript & """></A>"
0115 'The above looks uply, without being super-helpful, so was removed on 01/04/2021
0116 strLink2 = "</A></U><SUB>" & iSuperscript & "</SUB>" & "<a name=""On-Page_Return_" & NoteID & "_" & iSuperscript & """></A>"
0117 If Mid(strLine, FN_Start - 1, 1) = " " Then
0118 TheWord = Mid(strLine, i, FN_Start - 1 - i)
0119 Else
0120 TheWord = Mid(strLine, i, FN_Start - i)
0121 End If
0122 If Right(TheWord, 1) = "]" Then
0123 TheWord = Mid(TheWord, 2, Len(TheWord) - 2)
0124 End If
0125 xx = Left(strLine, i - 1) & strLink1 & TheWord & strLink2
0126 x = Len(xx)
0127 strLine = xx & Mid(strLine, FN_End + 1)
0128 iSuperscript = iSuperscript + 1
0129 End If
0130 x = x + 1
0131 x = InStr(x, strLine, "++")
0132 End If
0133 Else
0134 No_FN = "Yes"
0135 'Ignore Note-links (ie. links to other Notes)
0136 x = x + 1
0137 x = InStr(x, strLine, "++")
0138 If x > 0 Then
0139 x = x + 2
0140 x = InStr(x, strLine, "++")
0141 iSuperscript = iSuperscript + 1
0142 End If
0143 End If
0144 Else
0145 No_FN = "Yes"
0146 End If
0147 Loop
0148End If
0149iSuperscript = 1
0150x = 1
0151x = InStr(x, strLine, "++")
0152z = 1
0153iSection = 0
0154If x > 0 Then
0155 z = InStr(x, strLine, "<BR>")
0156End If
0157If Test_Flag = True Then
0158 Debug.Print Now(); "Notes_Text_Format"; NoteID; Note_Ref; Last_Changed_Timestamp; sw2.EndTimer; "Milliseconds"; " Note Links Created"
0159 sw2.StartTimer
0160End If
0161'Encode WebRefs now lest "+"'s confuse later processing
0162 strLine = WebEncode(strLine)
0163Do While x > 0
0164 'Skip over superscripts used by internal footnotes
0165 FN_Number_Used = "Yes"
0166 Do While FN_Number_Used = "Yes"
0167 strQuery = "Select * From Note_Footnotes Where Note_Footnotes!Note_ID = " & NoteID & " AND Note_Footnotes!FN_ID = " & iSuperscript & ";"
0168 Set rst2 = db.OpenRecordset(strQuery)
0169 If Not rst2.EOF Then
0170 iSuperscript = iSuperscript + 1
0171 Else
0172 FN_Number_Used = "No"
0173 End If
0174 Set rst2 = Nothing
0175 Loop
0176 If x > 1 Then
0177 If Mid(strLine, x - 1, 1) = " " Then
0178 i = FindWord(strLine, x - 1, "]")
0179 TheWord = Mid(strLine, i, x - 1 - i)
0180 Else
0181 i = FindWord(strLine, x, "]")
0182 TheWord = Mid(strLine, i, x - i)
0183 End If
0184 Else
0185 i = FindWord(strLine, x, "]")
0186 End If
0187 strPrintThisSuperscript = "Yes"
0188 DudRef = "No"
0189 strRef = ""
0190 Y = InStr(x + 1, strLine, "++")
0191 If Y = 0 Then
0192 x = 0
0193 DudRef = "Yes"
0194 Else
0195 If Y > x + 30 Then
0196 x = Y - 1
0197 DudRef = "Yes"
0198 Else
0199 If Y = x + 1 Then
0200 'Check this is the "++++" case where we have to look up the reference
0201 If Mid(strLine, x, 4) = "++++" Then
0202 'Find the key-word(s)
0203 If Right(TheWord, 1) = "]" Then
0204 TheWord = Mid(TheWord, 2, Len(TheWord) - 2)
0205 End If
0206 'Find the Note ID. NB uses the Note_Alternates table!
0207 Set rsNoteID = CurrentDb.OpenRecordset("SELECT Notes.ID FROM Note_Alternates INNER JOIN Notes ON Note_Alternates.Item_Title = Notes.Item_Title WHERE (((Note_Alternates.Item_Alt_Title)=""" & TheWord & """));")
0208 If rsNoteID.EOF Then
0209 strRef = "1256" 'The "dud links" Note!
0210 Else
0211 rsNoteID.MoveFirst
0212 strRef = rsNoteID.Fields(0)
0213 End If
0214 Set rsNoteID = Nothing
0215 strLine = Left(strLine, x + 1) & strRef & Mid(strLine, x + 2)
0216 Y = Y + 1 + Len(strRef)
0217 End If
0218 Else
0219 strRef = Mid(strLine, x + 2, Y - x - 2)
0220 End If
0221 If Left(strRef, 2) = "NP" Then
0222 strRef = Mid(strRef, 3, Len(strRef))
0223 strPrintThisSuperscript = "No"
0224 End If
0225 If Len(strRef) > 0 Then
0226 If InStr(strRef, "#") > 0 Then
0227 If IsNumeric(Left(strRef, InStr(strRef, "#") - 1)) Then
0228 iFootNoteID = Left(strRef, InStr(strRef, "#") - 1)
0229 strRef = Mid(strRef, InStr(strRef, "#"), Len(strRef))
0230 strRef = Replace(strRef, "#", "#Off-Page_Link_")
0231 Else
0232 x = Y - 1
0233 DudRef = "Yes"
0234 End If
0235 Else
0236 If IsNumeric(strRef) Then
0237 iFootNoteID = strRef
0238 strRef = ""
0239 Else
0240 x = Y - 1
0241 DudRef = "Yes"
0242 End If
0243 End If
0244 End If
0245 End If
0246 End If
0247 If DudRef = "No" Then
0248 'Find whether to Print the superscript (if not already decided not to print)
0249 If strPrintThisSuperscript = "Yes" Then
0250 If (Not IsMissing(strPrintable)) And (Val(Note_Ref) <> 0) Then
0251 'Just use this recordset for convenience
0252 Set rsSecure = CurrentDb.OpenRecordset("SELECT Note_Usage_Temp.Note_From FROM Note_Usage_Temp WHERE (((Note_Usage_Temp.Note_ID)=" & Val(iFootNoteID) & "));")
0253 If strPrintDuplicateFootnoteRefs = "No" Then
0254 If rsSecure.EOF Then
0255 strPrintThisSuperscript = "No"
0256 Else
0257 rsSecure.MoveFirst
0258 If Val(Note_Ref) <> rsSecure.Fields(0).Value Then 'FIX - re "print all"
0259 strPrintThisSuperscript = "No"
0260 End If
0261 End If
0262 End If
0263 End If
0264 End If
0265 Set rsSecure = Nothing
0266 'Find its Notes_Group
0267 strDirectory = "../"
0268 If Notes_Group_Name <> "N/A" Then
0269 'Determine if across secure area
0270 Set rsSecure = CurrentDb.OpenRecordset("SELECT Note_Groups.Note_Group FROM Notes INNER JOIN Note_Groups ON Notes.Note_Group = Note_Groups.ID WHERE (((Notes.ID)=" & iFootNoteID & "));")
0271 If rsSecure.EOF Then
0272 strDirectory = "../../Notes/"
0273 Else
0274 rsSecure.MoveFirst
0275 If rsSecure.Fields(0) <> Notes_Group_Name Then
0276 If rsSecure.Fields(0) = "Supervisions" Then
0277 strDirectory = "../../Secure_Jen/"
0278 Else
0279 If Notes_Group_Name = "Supervisions" Then
0280 strDirectory = "../../Notes/"
0281 End If
0282 End If
0283 End If
0284 End If
0285 End If
0286 FootNoteTimestamp = 0
0287 If Last_Changed_Timestamp > 0 Then 'This is either just a flag, or an actual timestamp
0288 If Last_Changed_Timestamp < 50000 Then
0289 Last_Changed_Timestamp = 50000000
0290 End If
0291 'Find latest Timestamp for links
0292 Set rsLatestTimestamp = CurrentDb.OpenRecordset("SELECT Max(Notes_Archive.Timestamp) AS MaxOfTimestamp FROM Notes_Archive WHERE (((Notes_Archive.Timestamp)<=" & Last_Changed_Timestamp & ")) GROUP BY Notes_Archive.ID HAVING (((Notes_Archive.ID)=" & iFootNoteID & "));")
0293 If Not rsLatestTimestamp.EOF Then
0294 rsLatestTimestamp.MoveFirst
0295 FootNoteTimestamp = rsLatestTimestamp.Fields(0).Value
0296 End If
0297 Set rsLatestTimestamp = CurrentDb.OpenRecordset("SELECT Max(Notes_Archive.Timestamp) AS MaxOfTimestamp FROM Notes_Archive WHERE (((Notes_Archive.Timestamp)<=" & Last_Changed_Timestamp & ")) GROUP BY Notes_Archive.ID HAVING (((Notes_Archive.ID)=" & iFootNoteID & "));")
0298 If FootNoteTimestamp = 0 Then
0299 Set rsLatestTimestamp = CurrentDb.OpenRecordset("SELECT Min(Notes_Archive.Timestamp) AS MinOfTimestamp FROM Notes_Archive WHERE (((Notes_Archive.Timestamp)>=" & Last_Changed_Timestamp & ")) GROUP BY Notes_Archive.ID HAVING (((Notes_Archive.ID)=" & iFootNoteID & "));")
0300 If Not rsLatestTimestamp.EOF Then
0301 rsLatestTimestamp.MoveFirst
0302 FootNoteTimestamp = rsLatestTimestamp.Fields(0).Value
0303 End If
0304 End If
0305 Set rsLatestTimestamp = Nothing
0306 End If
0307 If Ref_Type = "N" Then
0308 OK = Cross_Reference_Add(Ref_Type, NoteID, Last_Changed_Timestamp, "N", iFootNoteID, FootNoteTimestamp)
0309 End If
0310 strControlQuery = "SELECT Notes.[Private?] FROM Notes WHERE (((Notes.ID)=" & iFootNoteID & "));"
0311 Set rsNoteType = CurrentDb.OpenRecordset(strControlQuery)
0312 If Not rsNoteType.EOF Then
0313 If rsNoteType.Fields(0).Value = "Yes" Then
0314 If IsMissing(strPrintable) Then
0315 strLink1 = "<A HREF = """ & strDirectory & "Notes_" & Find_New_Directory(iFootNoteID) & "/Notes_" & iFootNoteID & IIf(FootNoteTimestamp > 0, "_" & FootNoteTimestamp, "") & ".htm" & strRef & """>"
0316 If WordFound = "Yes" Then
0317 strLink2 = "</A><SUB>" & iSuperscript & "</SUB>"
0318 Else
0319 strLink2 = "<SUB>" & iSuperscript & "</SUB></A>"
0320 End If
0321 Else
0322 If Val(strPrintable) > 0 And strPrintThisSuperscript = "Yes" Then
0323 strLink1 = "<U>"
0324 strLink2 = "</U><SUB>" & iSuperscript & "</SUB>"
0325 Else
0326 strLink1 = ""
0327 strLink2 = ""
0328 End If
0329 End If
0330 Else
0331 If IsMissing(strPrintable) Then
0332 strLink1 = "<A HREF = """ & strDirectory & "Notes_" & Find_New_Directory(iFootNoteID) & "/Notes_" & iFootNoteID & IIf(FootNoteTimestamp > 0, "_" & FootNoteTimestamp, "") & ".htm" & strRef & """>"
0333 If WordFound = "Yes" Then
0334 strLink2 = "</A><SUP>" & iSuperscript & "</SUP>"
0335 Else
0336 strLink2 = "<SUP>" & iSuperscript & "</SUP></A>"
0337 End If
0338 Else
0339 If Val(strPrintable) > 0 And strPrintThisSuperscript = "Yes" Then
0340 strLink1 = "<U>"
0341 strLink2 = "</U><SUP>" & iSuperscript & "</SUP>"
0342 Else
0343 strLink1 = ""
0344 strLink2 = ""
0345 End If
0346 End If
0347 End If
0348 Else
0349 If IsMissing(strPrintable) Then
0350 strLink1 = "<A HREF = """ & strDirectory & "Notes_" & Find_New_Directory(iFootNoteID) & "/Notes_" & iFootNoteID & IIf(FootNoteTimestamp > 0, "_" & FootNoteTimestamp, "") & ".htm" & strRef & """>"
0351 If WordFound = "Yes" Then
0352 strLink2 = "</A><SUP>" & iSuperscript & "</SUP>"
0353 Else
0354 strLink2 = "<SUP>" & iSuperscript & "</SUP></A>"
0355 End If
0356 Else
0357 If Val(strPrintable) > 0 And strPrintThisSuperscript = "Yes" Then
0358 strLink1 = "<U>"
0359 strLink2 = "</U><SUP>" & iSuperscript & "</SUP>"
0360 Else
0361 strLink1 = ""
0362 strLink2 = ""
0363 End If
0364 End If
0365 End If
0366 z = z + Len(strLink1) + Len(strLink2) - (Y - x + 2)
0367 If z < 1 Then
0368 z = 1
0369 End If
0370 If WordFound = "Yes" Then
0371 If Mid(strLine, x - 1, 1) = " " Then
0372 TheWord = Mid(strLine, i, x - 1 - i)
0373 z = z - 1
0374 Else
0375 TheWord = Mid(strLine, i, x - i)
0376 End If
0377 If Right(TheWord, 1) = "]" Then
0378 TheWord = Mid(TheWord, 2, Len(TheWord) - 2)
0379 End If
0380 Else
0381 TheWord = ""
0382 End If
0383 strLine = Left(strLine, i - 1) & "<a name=""N" & iFootNoteID & "_" & OK & """></a>" & strLink1 & TheWord & strLink2 & Mid(strLine, Y + 2, Len(strLine))
0384 If x > z Then
0385 iSection = iSection + 1
0386 z = InStr(z + 5, strLine, "<BR>")
0387 If z = 0 Then
0388 z = 10000000
0389 End If
0390 End If
0391 x = InStr(x, strLine, "++")
0392 'Ignore In-sheet Footnotes
0393 If x > 0 Then
0394 No_FN = "No"
0395 Do Until No_FN = "Yes"
0396 If x > 0 Then
0397 If Mid(strLine, x + 2, 2) = "FN" Then
0398 FN_Start = x
0399 x = x + 1
0400 x = InStr(x, strLine, "++")
0401 If x > 0 Then
0402 FN_End = x + 1
0403 Footnote_Text = Mid(strLine, FN_Start + 4, FN_End - FN_Start - 5) & ""
0404 If Footnote_Text <> "" Then
0405 If Mid(strLine, FN_Start - 1, 1) = " " Then
0406 i = FindWord(strLine, FN_Start - 1, "]")
0407 Else
0408 i = FindWord(strLine, FN_Start, "]")
0409 End If
0410 strLink1 = "<U><A HREF=""#On-Page_Link_" & NoteID & "_" & iSuperscript & """>"
0411 strLink2 = "</A></U><SUB>" & iSuperscript & "</SUB>"
0412 If Mid(strLine, FN_Start - 1, 1) = " " Then
0413 TheWord = Mid(strLine, i, FN_Start - 1 - i)
0414 Else
0415 TheWord = Mid(strLine, i, FN_Start - i)
0416 End If
0417 If Right(TheWord, 1) = "]" Then
0418 TheWord = Mid(TheWord, 2, Len(TheWord) - 2)
0419 End If
0420 'Add to table
0421 rst.AddNew
0422 rst.Fields(0) = NoteID
0423 rst.Fields(1) = iSuperscript
0424 rst.Fields(2) = Footnote_Text
0425 rst.Fields(3) = Now()
0426 rst.Update
0427 strLine = Left(strLine, i - 1) & strLink1 & TheWord & strLink2 & Mid(strLine, FN_End + 1)
0428 iSuperscript = iSuperscript + 1
0429 End If
0430 x = x + 1
0431 x = InStr(x, strLine, "++")
0432 End If
0433 Else
0434 No_FN = "Yes"
0435 End If
0436 Else
0437 No_FN = "Yes"
0438 End If
0439 Loop
0440 End If
0441 iSuperscript = iSuperscript + 1
0442 Else
0443 x = x + 1
0444 x = InStr(x, strLine, "++")
0445 End If
0446Loop
0447If Test_Flag = True Then
0448 Debug.Print Now(); "Notes_Text_Format"; NoteID; Note_Ref; Last_Changed_Timestamp; sw2.EndTimer; "Milliseconds"; " Note Superscripts Created"
0449 sw2.StartTimer
0450End If
0451'Create the Note-Paper links
0452 OK = Reference_Papers(strLine, Ref_Type, NoteID, Last_Changed_Timestamp)
0453If Test_Flag = True Then
0454 Debug.Print Now(); "Notes_Text_Format"; NoteID; Note_Ref; Last_Changed_Timestamp; sw2.EndTimer; "Milliseconds"; " Note-Paper links Created"
0455 sw2.StartTimer
0456End If
0457'Create the Note-Books links
0458 OK = Reference_Books(strLine, Ref_Type, NoteID, Last_Changed_Timestamp)
0459If Test_Flag = True Then
0460 Debug.Print Now(); "Notes_Text_Format"; NoteID; Note_Ref; Last_Changed_Timestamp; sw2.EndTimer; "Milliseconds"; " Note-Book links Created"
0461 sw2.StartTimer
0462End If
0463'Replace the Author References by hyperlinks
0464 OK = Reference_Author(strLine, Ref_Type, NoteID, Last_Changed_Timestamp)
0465If Test_Flag = True Then
0466 Debug.Print Now(); "Notes_Text_Format"; NoteID; Note_Ref; Last_Changed_Timestamp; sw2.EndTimer; "Milliseconds"; " Author links Created"
0467 sw2.StartTimer
0468End If
0469'Replace the Note Links References by hyperlinks
0470If IsMissing(strPrintable) Then
0471 OK = Reference_Note_Links(strLine, Ref_Type, NoteID, Last_Changed_Timestamp)
0472Else
0473 OK = Reference_Note_Links(strLine, "NP", NoteID, Last_Changed_Timestamp)
0474End If
0475If Test_Flag = True Then
0476 Debug.Print Now(); "Notes_Text_Format"; NoteID; Note_Ref; Last_Changed_Timestamp; sw2.EndTimer; "Milliseconds"; " Note links Created"
0477 sw2.StartTimer
0478End If
0479'Replace References (not sure required ...)
0480 OK = Reference_Reference(strLine)
0481'Replace References to Code
0482 OK = Reference_Code(strLine)
0483 OK = Reference_Code_Bridge(strLine)
0484 OK = Reference_Tables(strLine) 'Replace Table-references by hyperlinks
0485 OK = Reference_Queries(strLine) 'Replace Query-references by hyperlinks
0486'Bullets
0487 strLine = NumberedBullets(strLine)
0488 strLine = Bullets(strLine)
0489'Colours
0490 OK = Mark_Colours(strLine)
0491'Weblinks
0492If IsMissing(strPrintable) Then
0493 OK = Reference_Webrefs(strLine, Ref_Type, NoteID, Last_Changed_Timestamp)
0494Else
0495 OK = Reference_Webrefs(strLine, Ref_Type, NoteID, Last_Changed_Timestamp, "Show")
0496End If
0497 strLine = ImageRef(strLine, "Notes", Ref_Type, NoteID, Last_Changed_Timestamp)
0498 OK = Classification_Change(strLine)
0499If Test_Flag = True Then
0500 Debug.Print Now(); "Notes_Text_Format"; NoteID; Note_Ref; Last_Changed_Timestamp; sw2.EndTimer; "Milliseconds"; " Sundry minor referencing"
0501 sw2.StartTimer
0502End If
0503'Log Referencing Changes
0504If Full_Regen = False Then
0505 DoCmd.OpenQuery ("Cross_Reference_Changes_Deletions_Add")
0506End If
0507If Test_Flag = True Then
0508 Debug.Print Now(); "Notes_Text_Format"; NoteID; Note_Ref; Last_Changed_Timestamp; sw2.EndTimer; "Milliseconds"; " Cross_Reference_Changes_Deletions_Add"
0509 sw2.StartTimer
0510End If
0511'Log Referencing Changes
0512If Full_Regen = False Then
0513 DoCmd.OpenQuery ("Cross_Reference_Changes_Additions_Add")
0514End If
0515If Test_Flag = True Then
0516 Debug.Print Now(); "Notes_Text_Format"; NoteID; Note_Ref; Last_Changed_Timestamp; sw2.EndTimer; "Milliseconds"; " Cross_Reference_Changes_Additions_Add"
0517 sw2.StartTimer
0518End If
0519If IsMissing(strPrintable) Then
0520 Cross_Reference_Table_Open = False
0521 Set rsCross_Reference_Table = Nothing
0522 DoCmd.OpenQuery ("Cross_Reference_Idempotency_Zap")
0523End If
0524If Test_Flag = True Then
0525 Debug.Print Now(); "Notes_Text_Format"; NoteID; Note_Ref; Last_Changed_Timestamp; sw.EndTimer; "Milliseconds"
0526End If
0527If Test_Flag = True Then
0528 Set sw = Nothing
0529 Set sw2 = Nothing
0530End If
0531Set rst = Nothing
0532End Function

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


Source Code of: NumberedBullets
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 120
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function NumberedBullets(strString)
0002Dim iListstart As Long
0003Dim iListEnd As Long
0004Dim iNextBullet As Long
0005Dim strStringTemp As String
0006Dim endTag As String
0007Dim startTag As String
0008Dim i As Long
0009Dim j As Long
0010Dim strFirstNumber As String
0011Dim k As Integer
0012Dim Delimiter As String
0013Dim Widget As String
0014Dim Len_strFirstNumber As Long
0015'Note: to start the numbered list at x other than 1, a, A, i, I, code |xx|y|x|. y is always an arabic number, and can be 0 or negative
0016strStringTemp = strString
0017For k = 1 To 5
0018 iListstart = 1
0019 iListEnd = 1
0020 Select Case k
0021 Case 1
0022 Delimiter = "|99|" 'Numbers ... has to go first because of the "start over-ride"
0023 Widget = "1"
0024 Case 2
0025 Delimiter = "|ii|" 'Lowercase Roman
0026 Widget = "i"
0027 Case 3
0028 Delimiter = "|II|" 'Uppercase Roman
0029 Widget = "I"
0030 Case 4
0031 Delimiter = "|aa|" 'Lowercase Letters
0032 Widget = "a"
0033 Case 5
0034 Delimiter = "|AA|" 'Uppercase Letters
0035 Widget = "A"
0036 Case Else
0037 End Select
0038 OK = Check_Delimiters(strString, Delimiter)
0039 'Numbered Lists
0040 Do While iListstart <> 0 And iListEnd <> 0
0041 iListstart = InStr(iListEnd, strStringTemp, Delimiter, vbBinaryCompare)
0042 If iListstart > 0 Then
0043 iListEnd = InStr(iListstart + 1, strStringTemp, Delimiter, vbBinaryCompare)
0044 End If
0045 If iListstart <> 0 And iListEnd <> 0 Then
0046 'Check for start-number over-ride
0047 'Note: I have a use of "|0|" for unnumbered bullets in a list, so I have to watch out for confusion between this and a list starting "0"
0048 startTag = ""
0049 strFirstNumber = ""
0050 i = InStr(iListstart + 1, strStringTemp, "|1|")
0051 j = InStr(iListstart + 1, strStringTemp, "|0|")
0052 If Mid(strStringTemp, j + 2, 3) = "|1|" Then
0053 j = 0
0054 End If
0055 If j > 0 Then
0056 If i > 0 Then
0057 If j < i Then
0058 i = j
0059 End If
0060 Else
0061 i = j
0062 End If
0063 End If
0064 If i > iListEnd Then
0065 i = 0
0066 End If
0067 Len_strFirstNumber = 0
0068 If i > 0 Then
0069 If i - iListstart > 4 Then
0070 strFirstNumber = Mid(strStringTemp, iListstart + 4, i - iListstart - 4)
0071 Len_strFirstNumber = Len(strFirstNumber)
0072 If IsNumeric(Trim(strFirstNumber)) Then
0073 startTag = "start = """ & Trim(strFirstNumber) & """ "
0074 Else
0075 i = iListstart + 4
0076 strFirstNumber = ""
0077 Len_strFirstNumber = 0
0078 End If
0079 End If
0080 Else
0081 'Check to ensure the |1|'s haven't already been stolen by another numbered list!
0082 i = InStr(iListstart + 1, strStringTemp, "<li>")
0083 If i > iListEnd Then
0084 i = 0
0085 End If
0086 If i > 0 Then
0087 If i - iListstart > 4 Then
0088 strFirstNumber = Mid(strStringTemp, iListstart + 4, i - iListstart - 4)
0089 Len_strFirstNumber = Len(strFirstNumber)
0090 strFirstNumber = Replace(strFirstNumber, "</li>", "")
0091 If IsNumeric(Trim(strFirstNumber)) Then
0092 startTag = "start = """ & Trim(strFirstNumber) & """ "
0093 End If
0094 End If
0095 Else
0096 i = iListstart + 4
0097 End If
0098 End If
0099 endTag = ""
0100 strStringTemp = Left(strStringTemp, iListstart - 1) & "<ol " & startTag & "type=""" & Widget & """>" & Mid(strStringTemp, i, Len(strStringTemp))
0101 iListEnd = iListEnd - 4 + 13 + Len(startTag) - Len_strFirstNumber
0102 iNextBullet = InStr(iListstart + 1, strStringTemp, "|1|")
0103 Do While iNextBullet <> 0 And iNextBullet < iListEnd
0104 If iNextBullet <> 0 Then
0105 strStringTemp = Left(strStringTemp, iNextBullet - 1) & endTag & "<li>" & Mid(strStringTemp, iNextBullet + 3, Len(strStringTemp))
0106 iListEnd = iListEnd - 3 + Len(endTag) + 4
0107 End If
0108 endTag = "</li>"
0109 iNextBullet = InStr(iNextBullet + 1, strStringTemp, "|1|")
0110 Loop
0111 strStringTemp = Left(strStringTemp, iListEnd - 1) & endTag & "</ol>" & Mid(strStringTemp, iListEnd + 4, Len(strStringTemp))
0112 iListEnd = iListEnd - 4 + Len(endTag) + 5
0113 End If
0114 Loop
0115Next k
0116strStringTemp = Replace(strStringTemp, "|0|", "")
0117strStringTemp = Replace(strStringTemp, "<BR></li>", "</li>")
0118strStringTemp = Replace(strStringTemp, "<BR><li>", "<li>")
0119NumberedBullets = strStringTemp
0120End Function

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


Source Code of: Reference_Books
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 81
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Reference_Books(strText, Calling_Type, Calling_ID, Calling_Timestamp, Optional Depth)
0002Dim x As Long
0003Dim Y As Long
0004Dim z As String
0005Dim BookRef As Long
0006Dim strBookRef As String
0007Dim strText_Local As String
0008Dim strText_End As String
0009Dim qryString As String
0010Dim rsTableToRead As Recordset
0011Dim BookTitle As String
0012Dim iDepth As Integer
0013Dim strPrefix As String
0014Dim i As Integer
0015Dim strName As String
0016If Len(strText) = 0 Then
0017 Reference_Books = "Not Found"
0018 Exit Function
0019End If
0020If IsMissing(Depth) Then
0021 iDepth = 2
0022Else
0023 iDepth = Depth
0024End If
0025i = 0
0026strPrefix = ""
0027Do While i < iDepth
0028 strPrefix = strPrefix & "../"
0029 i = i + 1
0030Loop
0031strText_Local = strText
0032x = 1
0033x = InStr(x, strText_Local, "+B")
0034Reference_Books = "Not Found"
0035Do While x > 0
0036 Reference_Books = "Found"
0037 Y = InStr(x + 1, strText_Local, "B+")
0038 'Watch out for false positives in finding +B
0039 If Y = 0 Then
0040 x = x + 1
0041 Else
0042 If Y - x > 7 Then
0043 x = x + 1
0044 Else
0045 strBookRef = Mid(strText_Local, x + 2, Y - x - 2)
0046 If Not IsNumeric(strBookRef) Then
0047 x = x + 1
0048 Else
0049 BookRef = Trim(strBookRef)
0050 If Y > Len(strText_Local) - 2 Then
0051 strText_End = ""
0052 Else
0053 strText_End = Mid(strText_Local, Y + 2, Len(strText_Local))
0054 End If
0055 If Calling_Type <> "X" Then
0056 OK = Cross_Reference_Add(Calling_Type, Calling_ID, Calling_Timestamp, "B", BookRef, 0)
0057 strName = "<a name=""B" & strBookRef & "_" & OK & """></a>"
0058 Else
0059 strName = ""
0060 End If
0061 'Determine Book Title & Add link
0062 BookTitle = ""
0063 qryString = "SELECT Books.Author, Books.Title FROM Books WHERE (((Books.ID1)=" & BookRef & "));"
0064 Set rsTableToRead = CurrentDb.OpenRecordset(qryString)
0065 If Not rsTableToRead.EOF Then
0066 rsTableToRead.MoveFirst
0067 BookTitle = rsTableToRead.Fields(0).Value & " - " & rsTableToRead.Fields(1).Value
0068 z = Str(Int(BookRef / 1000) + 1000000)
0069 strText_Local = Left(strText_Local, x - 1) & strName & """<A HREF = """ & strPrefix & "BookSummaries/BookSummary_" & Right(z, 2) & "/BookPaperAbstracts/BookPaperAbstracts_" & BookRef & ".htm"">" & BookTitle & "</A>""" & strText_End
0070 Else
0071 BookTitle = """Unknown Book"""
0072 strText_Local = Left(strText_Local, x - 1) & BookTitle & strText_End
0073 End If
0074 Set rsTableToRead = Nothing
0075 End If
0076 End If
0077 End If
0078 x = InStr(x, strText_Local, "+B")
0079Loop
0080strText = strText_Local
0081End Function

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


Source Code of: Reference_Notes
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 338
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Reference_Notes(strText, Calling_Type, Calling_ID, Calling_Timestamp, Optional Depth, Optional strType, Optional strBookPaper, Optional DocID)
0002Dim x As Long
0003Dim qq As Long
0004Dim Y As Long
0005Dim z As Long
0006 Dim yy As Long
0007Dim zz As Long
0008Dim Noteref As Integer
0009Dim Noteref_Text As String
0010Dim strText_Local As String
0011Dim strText_End As String
0012Dim qryString As String
0013Dim rsTableToRead As Recordset
0014Dim rsNoteID As Recordset
0015Dim NotesGroup As Integer
0016Dim NoteSubDirectory As String
0017Dim iDepth As Integer
0018Dim strPrefix As String
0019Dim i As Integer
0020Dim strPre As String
0021Dim strPost As String
0022Dim strNoteSource As String
0023Dim strLinkText As String
0024Dim j As Integer
0025Dim No_FN As String
0026Dim strText_Ref As String
0027Dim TheWord As String
0028Dim strName As String
0029On Error GoTo ErrorExit
0030If Len(strText) = 0 Then
0031 Reference_Notes = "Not Found"
0032 Exit Function
0033End If
0034j = 0
0035If IsMissing(Depth) Then
0036 iDepth = 2
0037Else
0038 iDepth = Depth
0039End If
0040If IsMissing(strType) Then
0041 strNoteSource = "Abstract"
0042Else
0043 strNoteSource = strType
0044End If
0045If strNoteSource = "Abstract" Then
0046 strPre = "+N"
0047 strPost = "N+"
0048Else
0049 strPre = "++"
0050 strPost = "++"
0051End If
0052i = 0
0053strPrefix = ""
0054Do While i < iDepth
0055 strPrefix = strPrefix & "../"
0056 i = i + 1
0057Loop
0058strText_Local = strText
0059x = 1
0060x = InStr(x, strText_Local, strPre)
0061'Ignore In-sheet Footnotes
0062No_FN = "No"
0063Do Until No_FN = "Yes"
0064 If x > 0 Then
0065 qq = x
0066 If Mid(strText_Local, x + 2, 2) = "FN" Then
0067 x = x + 1
0068 j = j + 1
0069 x = InStr(x, strText_Local, "++")
0070 If x > 0 Then
0071 If x = qq + 4 Then
0072 'Ie. have found ++FN++ marker ... so remove it
0073 strText_Local = Left(strText_Local, qq - 1) & Mid(strText_Local, qq + Len("++FN++"), Len(strText_Local))
0074 x = qq
0075 End If
0076 x = x + 1
0077 x = InStr(x, strText_Local, strPre)
0078 End If
0079 Else
0080 No_FN = "Yes"
0081 End If
0082 Else
0083 No_FN = "Yes"
0084 End If
0085Loop
0086'If strPre = +N, we need to watch out for ++NP, when strPost of N+ won't be found!
0087'... Hopefully this can be achieved by calling this routine in the right sequence *************
0088Reference_Notes = "Not Found"
0089If strNoteSource = "Abstract" Or strNoteSource = "Abstract_Direct" Then
0090 If Not IsMissing(strBookPaper) Then
0091 If strBookPaper = "Book" Then
0092 'Set up Note_Book_Links Recordset, if necessary
0093 If NoteBookLinksDB_Open <> "Open" Then
0094 NoteBookLinksDB_Open = "Open"
0095 Set rsNoteBookLinksDB = CurrentDb.OpenRecordset("SELECT Note_Book_Links.* FROM Note_Book_Links WHERE (((Note_Book_Links.Note)=999999));")
0096 End If
0097 'Delete any old Note_Book_Links
0098 DoCmd.RunSQL ("DELETE Note_Link_Zapper3.* FROM Note_Link_Zapper3;")
0099 DoCmd.RunSQL ("INSERT INTO Note_Link_Zapper3 ( [Note], Note_Ref, [Object], [Timestamp],ObjectType ) SELECT Note_Book_Links.Note, Note_Book_Links.Note_Ref, Note_Book_Links.Book, Note_Book_Links.Timestamp, Note_Book_Links.Origin FROM Note_Book_Links WHERE (((Note_Book_Links.Book)=" & DocID & ") AND ((Note_Book_Links.Origin)=""Book""));")
0100 DoCmd.RunSQL ("DELETE Note_Book_Links.* FROM Note_Book_Links INNER JOIN Note_Link_Zapper3 ON (Note_Book_Links.Timestamp = Note_Link_Zapper3.Timestamp) AND (Note_Book_Links.Book = Note_Link_Zapper3.Object) AND (Note_Book_Links.Note_Ref = Note_Link_Zapper3.Note_Ref) AND (Note_Book_Links.Note = Note_Link_Zapper3.Note) AND (Note_Book_Links.Origin = Note_Link_Zapper3.ObjectType);")
0101 DoCmd.RunSQL ("DELETE Note_Link_Zapper3.* FROM Note_Link_Zapper3;")
0102 Else
0103 If strBookPaper = "Paper" Then
0104 'Set up Note_Paper_Links Recordset, if necessary
0105 If NotePaperLinksDB_Open <> "Open" Then
0106 NotePaperLinksDB_Open = "Open"
0107 Set rsNotePaperLinksDB = CurrentDb.OpenRecordset("SELECT Note_Paper_Links.* FROM Note_Paper_Links WHERE (((Note_Paper_Links.Note)=999999));")
0108 End If
0109 'Delete any old Note_Paper_Links
0110 DoCmd.RunSQL ("DELETE Note_Link_Zapper3.* FROM Note_Link_Zapper3;")
0111 DoCmd.RunSQL ("INSERT INTO Note_Link_Zapper3 ( [Note], Note_Ref, [Object], [Timestamp],ObjectType ) SELECT Note_Paper_Links.Note, Note_Paper_Links.Note_Ref, Note_Paper_Links.Paper, Note_Paper_Links.Timestamp, Note_Paper_Links.Origin FROM Note_Paper_Links WHERE (((Note_Paper_Links.Paper)=" & DocID & ") AND ((Note_Paper_Links.Origin)=""Paper""));")
0112 DoCmd.RunSQL ("DELETE Note_Paper_Links.* FROM Note_Paper_Links INNER JOIN Note_Link_Zapper3 ON (Note_Paper_Links.Timestamp = Note_Link_Zapper3.Timestamp) AND (Note_Paper_Links.Paper = Note_Link_Zapper3.Object) AND (Note_Paper_Links.Note_Ref = Note_Link_Zapper3.Note_Ref) AND (Note_Paper_Links.Note = Note_Link_Zapper3.Note) AND (Note_Paper_Links.Origin = Note_Link_Zapper3.ObjectType);")
0113 DoCmd.RunSQL ("DELETE Note_Link_Zapper3.* FROM Note_Link_Zapper3;")
0114 End If
0115 End If
0116 End If
0117End If
0118If x > 0 Then
0119 'Watch out for C++!! This could be more sophisticated ... a fudge for now!
0120 If Mid(strText_Local, x - 1, 1) = "C" And Mid(strText_Local, x - 2, 1) = " " And Not IsNumeric(Mid(strText_Local, x + 2, 1)) Then
0121 If Mid(strText_Local, x, 4) <> "++++" And Mid(strText_Local, x, 4) <> "+NN+" Then
0122 x = InStr(x + 1, strText_Local, strPre)
0123 End If
0124 End If
0125End If
0126Do While x > 0
0127 j = j + 1
0128 z = x
0129 Reference_Notes = "Found"
0130 If Mid(strText_Local, x + 2, 2) = "NP" Then
0131 x = x + 2
0132 Y = InStr(x, strText_Local, strPost)
0133 Else
0134 Y = InStr(x + 1, strText_Local, strPost)
0135 End If
0136 'Check for embedded in-page references
0137 If Y = 0 Or (Y - x) > 10 Then
0138 If Y = 0 Or (Y - x) > 85 Then
0139 Debug.Print Now() & " - "; Mid(strText_Local, x, 100)
0140 MsgBox "Reference_Notes: post-reference missing"
0141 Stop
0142 Else
0143 'check for references
0144 zz = InStr(Mid(strText_Local, x + 1, Y - x), "#")
0145 If zz = 0 Then
0146 Debug.Print Now() & " - "; Mid(strText_Local, x, 100)
0147 MsgBox "Reference_Notes: post-reference missing"
0148 Stop
0149 End If
0150 End If
0151 End If
0152 zz = InStr(x + 1, strText_Local, "#")
0153 strText_Ref = ""
0154 If zz > 0 Then
0155 If zz < Y Then
0156 strText_Ref = Mid(strText_Local, zz + 1, Y - zz - 1)
0157 End If
0158 End If
0159 zz = Len(strText_Ref)
0160 If zz > 0 Then
0161 zz = zz + 1
0162 End If
0163 If Y - x - 2 - zz < 1 Then
0164 'Check this is the "++++" or "+NN+" or "++NP++" case where we have to look up the reference ***************
0165 If Mid(strText_Local, x, 4) = "++++" Or Mid(strText_Local, x, 4) = "+NN+" Or Mid(strText_Local, x, 2) = "NP" Then
0166 yy = FindWord(strText_Local, x, "]")
0167 'Find the key-word(s)
0168 TheWord = Mid(strText_Local, yy, x - yy)
0169 If Right(TheWord, 1) = "]" Then
0170 TheWord = Mid(TheWord, 2, Len(TheWord) - 2)
0171 End If
0172 'Find the Note ID. NB uses the Note_Alternates table!
0173 Set rsNoteID = CurrentDb.OpenRecordset("SELECT Notes.ID FROM Note_Alternates INNER JOIN Notes ON Note_Alternates.Item_Title = Notes.Item_Title WHERE (((Note_Alternates.Item_Alt_Title)=""" & TheWord & """));")
0174 If rsNoteID.EOF Then
0175 Noteref_Text = "1256" 'The "dud links" Note!
0176 Else
0177 rsNoteID.MoveFirst
0178 Noteref_Text = rsNoteID.Fields(0)
0179 End If
0180 Set rsNoteID = Nothing
0181 strText_Local = Left(strText_Local, x + 1) & Noteref_Text & Mid(strText_Local, x + 2)
0182 If Mid(strText_Local, x, 2) = "++" Then
0183 Y = Y + 1 + Len(Noteref_Text)
0184 Else
0185 Y = Y + Len(Noteref_Text)
0186 End If
0187 Noteref = Noteref_Text
0188 End If
0189 Else
0190 Noteref_Text = Mid(strText_Local, x + 2, Y - x - 2 - zz)
0191 Noteref = Noteref_Text
0192 End If
0193 If Y > Len(strText_Local) - 2 Then
0194 strText_End = ""
0195 Else
0196 strText_End = Mid(strText_Local, Y + 2, Len(strText_Local))
0197 End If
0198 If Len(strText_Ref) > 0 Then
0199 strText_Ref = "#Off-Page_Link_" & strText_Ref
0200 End If
0201 If Calling_Type <> "X" Then
0202 OK = Cross_Reference_Add(Calling_Type, Calling_ID, Calling_Timestamp, "N", Noteref, 0)
0203 End If
0204 'Determine if Secure or Not
0205 qryString = "SELECT Notes.Note_Group FROM Notes WHERE (((Notes.ID)=" & Noteref & "));"
0206 Set rsTableToRead = CurrentDb.OpenRecordset(qryString)
0207 If Not rsTableToRead.EOF Then
0208 rsTableToRead.MoveFirst
0209 NotesGroup = rsTableToRead.Fields(0).Value
0210 Else
0211 NotesGroup = 0
0212 End If
0213 'Determine the Notes_Directory
0214 NoteSubDirectory = Find_New_Directory(Noteref)
0215 'Set up the link
0216 qq = 0
0217 TheWord = ""
0218 If strNoteSource = "Abstract" Or strNoteSource = "Abstract_Direct" Then
0219 If strNoteSource = "Abstract" Then
0220 If Mid(strText_Local, z - 1, 1) = "(" Or Mid(strText_Local, z - 1, 1) = " " Or Mid(strText_Local, z - 1, 1) = "|" Then
0221 strLinkText = "Click here for Note</A>"
0222 Else
0223 qq = FindWord(strText_Local, z - 1, "]")
0224 If qq > 0 Then
0225 TheWord = Trim(Mid(strText_Local, qq, z - qq))
0226 If Right(TheWord, 1) = "]" Then
0227 TheWord = Mid(TheWord, 2, Len(TheWord) - 2)
0228 End If
0229 qq = z - qq
0230 If Len(TheWord) > 0 Then
0231 strLinkText = TheWord & "</a>"
0232 End If
0233 End If
0234 End If
0235 Else
0236 qq = FindWord(strText_Local, z - 1, "]")
0237 strLinkText = "<SUP>" & j & "</SUP></A>"
0238 If qq > 0 Then
0239 TheWord = Trim(Mid(strText_Local, qq, z - qq))
0240 If Right(TheWord, 1) = "]" Then
0241 TheWord = Mid(TheWord, 2, Len(TheWord) - 2)
0242 End If
0243 qq = z - qq
0244 If Len(TheWord) > 0 Then
0245 strLinkText = TheWord & "</A><SUP>" & j & "</SUP>"
0246 End If
0247 End If
0248 End If
0249 If Not IsMissing(strBookPaper) Then
0250 'Add new Link
0251 If strBookPaper = "Book" Then
0252 rsNoteBookLinksDB.AddNew
0253 rsNoteBookLinksDB.Fields(0) = Noteref
0254 rsNoteBookLinksDB.Fields(1) = 0
0255 rsNoteBookLinksDB.Fields(2) = DocID
0256 rsNoteBookLinksDB.Fields(3) = 0
0257 rsNoteBookLinksDB.Fields(4) = strBookPaper
0258 rsNoteBookLinksDB.Fields(5) = Now()
0259 On Error Resume Next
0260 '... ********** in case of duplicates
0261 rsNoteBookLinksDB.Update
0262 On Error GoTo ErrorExit
0263 Else
0264 If strBookPaper = "Paper" Then
0265 rsNotePaperLinksDB.AddNew
0266 rsNotePaperLinksDB.Fields(0) = Noteref
0267 rsNotePaperLinksDB.Fields(1) = 0
0268 rsNotePaperLinksDB.Fields(2) = DocID
0269 rsNotePaperLinksDB.Fields(3) = 0
0270 rsNotePaperLinksDB.Fields(4) = strBookPaper
0271 rsNotePaperLinksDB.Fields(5) = Now()
0272 On Error Resume Next
0273 '... ********** in case of duplicates
0274 rsNotePaperLinksDB.Update
0275 On Error GoTo ErrorExit
0276 End If
0277 End If
0278 End If
0279 Else
0280 strLinkText = "<SUP>" & j & "</SUP></A>"
0281 End If
0282 If Calling_Type = "X" Then
0283 strName = ""
0284 Else
0285 strName = "N" & Noteref & "_" & OK
0286 strName = "<a name=""" & strName & """></a>"
0287 End If
0288 If NotesGroup <> 10 Then
0289 strText_Local = Left(strText_Local, z - 1 - qq) & strName & "<A HREF=""" & strPrefix & "Notes/Notes_" & NoteSubDirectory & "/Notes_" & Noteref & ".htm" & strText_Ref & """>" & strLinkText & strText_End
0290 Else
0291 strText_Local = Left(strText_Local, z - 1 - qq) & strName & "<A HREF=""" & strPrefix & "Secure_Jen/Notes_" & NoteSubDirectory & "/Notes_" & Noteref & ".htm" & strText_Ref & """>" & strLinkText & strText_End
0292 End If
0293 Set rsTableToRead = Nothing
0294 x = InStr(x, strText_Local, strPre)
0295 If x > 0 Then
0296 'Watch out for C++!! This could be more sophisticated ... a fudge for now!
0297 If Mid(strText_Local, x - 1, 1) = "C" And (Not IsNumeric(Mid(strText_Local, x + 2, 1)) And Mid(strText_Local, x + 2, 2) <> "NP") Then
0298 If Mid(strText_Local, x, 4) <> "++++" And Mid(strText_Local, x, 4) <> "+NN+" Then
0299 x = InStr(x + 1, strText_Local, strPre)
0300 End If
0301 End If
0302 End If
0303 'Ignore In-sheet Footnotes
0304 No_FN = "No"
0305 Do Until No_FN = "Yes"
0306 If x > 0 Then
0307 qq = x
0308 If Mid(strText_Local, x + 2, 2) = "FN" Then
0309 x = x + 1
0310 j = j + 1
0311 x = InStr(x, strText_Local, "++")
0312 If x > 0 Then
0313 If x = qq + 4 Then
0314 'Ie. have found ++FN++ marker ... so remove it
0315 strText_Local = Left(strText_Local, qq - 1) & Mid(strText_Local, qq + Len("++FN++"), Len(strText_Local))
0316 x = qq
0317 End If
0318 x = x + 1
0319 x = InStr(x, strText_Local, strPre)
0320 End If
0321 Else
0322 No_FN = "Yes"
0323 End If
0324 Else
0325 No_FN = "Yes"
0326 End If
0327 Loop
0328Loop
0329strText = strText_Local
0330Exit Function
0331ErrorExit:
0332Reference_Notes = "Error"
0333strLinkText = "Error in Sub Reference_Notes: Type=" & IIf(IsMissing(strType), "Missing", strType) & "; Book / Paper=" & IIf(IsMissing(strBookPaper), "Missing", strBookPaper) & "; DocID=" & IIf(IsMissing(DocID), "Missing", DocID)
0334strLinkText = strLinkText & "; Error = " & Err.Number & " (" & Err.Description & ")"
0335Debug.Print Now() & " - " & strLinkText
0336MsgBox strLinkText
0337Stop
0338End Function

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


Source Code of: Reference_Papers
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 85
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Reference_Papers(strText, Calling_Type, Calling_ID, Calling_Timestamp, Optional Depth)
0002Dim x As Long
0003Dim Y As Long
0004Dim z As String
0005Dim strPaperRef As String
0006Dim PaperRef As Long
0007Dim strText_Local As String
0008Dim strText_End As String
0009Dim qryString As String
0010Dim rsTableToRead As Recordset
0011Dim PaperTitle As String
0012Dim strName As String
0013Dim iDepth As Integer
0014Dim strPrefix As String
0015Dim i As Integer
0016If Len(strText) = 0 Then
0017 Reference_Papers = "Not Found"
0018 Exit Function
0019End If
0020If IsMissing(Depth) Then
0021 iDepth = 2
0022Else
0023 iDepth = Depth
0024End If
0025i = 0
0026strPrefix = ""
0027Do While i < iDepth
0028 strPrefix = strPrefix & "../"
0029 i = i + 1
0030Loop
0031strText_Local = strText
0032x = 1
0033x = InStr(x, strText_Local, "+P")
0034Reference_Papers = "Not Found"
0035Do While x > 0
0036 Reference_Papers = "Found"
0037 Y = InStr(x + 1, strText_Local, "P+")
0038 'Watch out for false positives in finding +P
0039 If Y = 0 Then
0040 x = x + 1
0041 Else
0042 If Y - x > 7 Then
0043 x = x + 1
0044 Else
0045 strPaperRef = Mid(strText_Local, x + 2, Y - x - 2)
0046 If Not IsNumeric(strPaperRef) Then
0047 x = x + 1
0048 Else
0049 PaperRef = Trim(strPaperRef)
0050 If Y > Len(strText_Local) - 2 Then
0051 strText_End = ""
0052 Else
0053 strText_End = Mid(strText_Local, Y + 2, Len(strText_Local))
0054 End If
0055 If Calling_Type <> "X" Then
0056 OK = Cross_Reference_Add(Calling_Type, Calling_ID, Calling_Timestamp, "P", PaperRef, 0)
0057 strName = "<a name=""P" & strPaperRef & "_" & OK & """></a>"
0058 Else
0059 strName = ""
0060 End If
0061 'Determine Paper Title & Add link
0062 PaperTitle = ""
0063 qryString = "SELECT Papers.Author, Papers.Title, Papers.Abstract_Quality, Papers.Comments FROM Papers WHERE (((Papers.ID)=" & PaperRef & "));"
0064 Set rsTableToRead = CurrentDb.OpenRecordset(qryString)
0065 If Not rsTableToRead.EOF Then
0066 rsTableToRead.MoveFirst
0067 PaperTitle = rsTableToRead.Fields(0).Value & " - " & rsTableToRead.Fields(1).Value
0068 z = Str(Int(PaperRef / 1000) + 1000000)
0069 If rsTableToRead.Fields(2).Value & "" = "" And rsTableToRead.Fields(3).Value & "" = "" Then
0070 strText_Local = Left(strText_Local, x - 1) & strName & """<A HREF = """ & strPrefix & "PaperSummaries/PaperSummary_" & Right(z, 2) & "/PaperSummary_" & PaperRef & ".htm"">" & PaperTitle & "</A>""" & strText_End
0071 Else
0072 strText_Local = Left(strText_Local, x - 1) & strName & """<A HREF = """ & strPrefix & "Abstracts/Abstract_" & Right(z, 2) & "/Abstract_" & PaperRef & ".htm"">" & PaperTitle & "</A>""" & strText_End
0073 End If
0074 Else
0075 PaperTitle = """Unknown Paper"""
0076 strText_Local = Left(strText_Local, x - 1) & PaperTitle & strText_End
0077 End If
0078 Set rsTableToRead = Nothing
0079 End If
0080 End If
0081 End If
0082 x = InStr(x, strText_Local, "+P")
0083Loop
0084strText = strText_Local
0085End Function

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


Source Code of: ReplaceCode
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 24
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function ReplaceCode(strString, Oldy, Newy)
0002Dim lenString As Long
0003Dim lenOldy As Long
0004Dim lenNewy As Long
0005Dim strTemp As String
0006Dim x As Long
0007strTemp = strString
0008lenString = Len(strTemp)
0009lenOldy = Len(Oldy)
0010lenNewy = Len(Newy)
0011x = 1
0012Do While x + lenOldy < lenString + 2
0013 If Mid(strTemp, x, lenOldy) = Oldy Then
0014 strTemp = Left(strTemp, x - 1) & Newy & Mid(strTemp, x + lenOldy, lenString - x - lenOldy + 20)
0015 lenString = lenString - lenOldy + lenNewy
0016 If lenNewy > 0 Then
0017 x = x + 1
0018 End If
0019 Else
0020 x = x + 1
0021 End If
0022Loop
0023ReplaceCode = strTemp
0024End Function

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


Source Code of: Widthcheck
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 28
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Widthcheck(Field_to_check)
0002Dim x As Integer
0003Dim Y As Integer
0004Dim Length_Max As Integer
0005Dim Length_Next As Integer
0006Dim Length_String As Integer
0007x = 0
0008Y = 1
0009Length_Max = 0
0010Length_String = Len(Field_to_check & "")
0011If Length_String = 0 Then
0012 Widthcheck = 0
0013 Exit Function
0014End If
0015Do Until Y = 0
0016 Y = InStr(x + 1, Field_to_check, " ")
0017 If Y > 0 Then
0018 Length_Next = Y - x
0019 Else
0020 Length_Next = Length_String - x
0021 End If
0022 If Length_Next > Length_Max Then
0023 Length_Max = Length_Next
0024 End If
0025 x = Y
0026Loop
0027Widthcheck = Length_Max
0028End Function

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


© Theo Todman, June 2007 - Sept 2024. 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