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