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: 527
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 If Mid(strLine, FN_Start - 1, 1) = " " Then
0117 TheWord = Mid(strLine, i, FN_Start - 1 - i)
0118 Else
0119 TheWord = Mid(strLine, i, FN_Start - i)
0120 End If
0121 If Right(TheWord, 1) = "]" Then
0122 TheWord = Mid(TheWord, 2, Len(TheWord) - 2)
0123 End If
0124 xx = Left(strLine, i - 1) & strLink1 & TheWord & strLink2
0125 x = Len(xx)
0126 strLine = xx & Mid(strLine, FN_End + 1)
0127 iSuperscript = iSuperscript + 1
0128 End If
0129 x = x + 1
0130 x = InStr(x, strLine, "++")
0131 End If
0132 Else
0133 No_FN = "Yes"
0134 'Ignore Note-links (ie. links to other Notes)
0135 x = x + 1
0136 x = InStr(x, strLine, "++")
0137 If x > 0 Then
0138 x = x + 2
0139 x = InStr(x, strLine, "++")
0140 iSuperscript = iSuperscript + 1
0141 End If
0142 End If
0143 Else
0144 No_FN = "Yes"
0145 End If
0146 Loop
0147End If
0148iSuperscript = 1
0149x = 1
0150x = InStr(x, strLine, "++")
0151z = 1
0152iSection = 0
0153If x > 0 Then
0154 z = InStr(x, strLine, "<BR>")
0155End If
0156If Test_Flag = True Then
0157 Debug.Print Now(); "Notes_Text_Format"; NoteID; Note_Ref; Last_Changed_Timestamp; sw2.EndTimer; "Milliseconds"; " Note Links Created"
0158 sw2.StartTimer
0159End If
0160'Encode WebRefs now lest "+"'s confuse later processing
0161 strLine = WebEncode(strLine)
0162Do While x > 0
0163 'Skip over superscripts used by internal footnotes
0164 FN_Number_Used = "Yes"
0165 Do While FN_Number_Used = "Yes"
0166 strQuery = "Select * From Note_Footnotes Where Note_Footnotes!Note_ID = " & NoteID & " AND Note_Footnotes!FN_ID = " & iSuperscript & ";"
0167 Set rst2 = db.OpenRecordset(strQuery)
0168 If Not rst2.EOF Then
0169 iSuperscript = iSuperscript + 1
0170 Else
0171 FN_Number_Used = "No"
0172 End If
0173 Set rst2 = Nothing
0174 Loop
0175 If x > 1 Then
0176 If Mid(strLine, x - 1, 1) = " " Then
0177 i = FindWord(strLine, x - 1, "]")
0178 TheWord = Mid(strLine, i, x - 1 - i)
0179 Else
0180 i = FindWord(strLine, x, "]")
0181 TheWord = Mid(strLine, i, x - i)
0182 End If
0183 Else
0184 i = FindWord(strLine, x, "]")
0185 End If
0186 strPrintThisSuperscript = "Yes"
0187 DudRef = "No"
0188 strRef = ""
0189 Y = InStr(x + 1, strLine, "++")
0190 If Y = 0 Then
0191 x = 0
0192 DudRef = "Yes"
0193 Else
0194 If Y > x + 30 Then
0195 x = Y - 1
0196 DudRef = "Yes"
0197 Else
0198 If Y = x + 1 Then
0199 'Check this is the "++++" case where we have to look up the reference
0200 If Mid(strLine, x, 4) = "++++" Then
0201 'Find the key-word(s)
0202 If Right(TheWord, 1) = "]" Then
0203 TheWord = Mid(TheWord, 2, Len(TheWord) - 2)
0204 End If
0205 'Find the Note ID. NB uses the Note_Alternates table!
0206 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 & """));")
0207 If rsNoteID.EOF Then
0208 strRef = "1256" 'The "dud links" Note!
0209 Else
0210 rsNoteID.MoveFirst
0211 strRef = rsNoteID.Fields(0)
0212 End If
0213 Set rsNoteID = Nothing
0214 strLine = Left(strLine, x + 1) & strRef & Mid(strLine, x + 2)
0215 Y = Y + 1 + Len(strRef)
0216 End If
0217 Else
0218 strRef = Mid(strLine, x + 2, Y - x - 2)
0219 End If
0220 If Left(strRef, 2) = "NP" Then
0221 strRef = Mid(strRef, 3, Len(strRef))
0222 strPrintThisSuperscript = "No"
0223 End If
0224 If Len(strRef) > 0 Then
0225 If InStr(strRef, "#") > 0 Then
0226 If IsNumeric(Left(strRef, InStr(strRef, "#") - 1)) Then
0227 iFootNoteID = Left(strRef, InStr(strRef, "#") - 1)
0228 strRef = Mid(strRef, InStr(strRef, "#"), Len(strRef))
0229 strRef = Replace(strRef, "#", "#Off-Page_Link_")
0230 Else
0231 x = Y - 1
0232 DudRef = "Yes"
0233 End If
0234 Else
0235 If IsNumeric(strRef) Then
0236 iFootNoteID = strRef
0237 strRef = ""
0238 Else
0239 x = Y - 1
0240 DudRef = "Yes"
0241 End If
0242 End If
0243 End If
0244 End If
0245 End If
0246 If DudRef = "No" Then
0247 'Find whether to Print the superscript (if not already decided not to print)
0248 If strPrintThisSuperscript = "Yes" Then
0249 If (Not IsMissing(strPrintable)) And (Val(Note_Ref) <> 0) Then
0250 'Just use this recordset for convenience
0251 Set rsSecure = CurrentDb.OpenRecordset("SELECT Note_Usage_Temp.Note_From FROM Note_Usage_Temp WHERE (((Note_Usage_Temp.Note_ID)=" & Val(iFootNoteID) & "));")
0252 If strPrintDuplicateFootnoteRefs = "No" Then
0253 If rsSecure.EOF Then
0254 strPrintThisSuperscript = "No"
0255 Else
0256 rsSecure.MoveFirst
0257 If Val(Note_Ref) <> rsSecure.Fields(0).Value Then 'FIX - re "print all"
0258 strPrintThisSuperscript = "No"
0259 End If
0260 End If
0261 End If
0262 End If
0263 End If
0264 Set rsSecure = Nothing
0265 'Find its Notes_Group
0266 strDirectory = "../"
0267 If Notes_Group_Name <> "N/A" Then
0268 'Determine if across secure area
0269 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 & "));")
0270 If rsSecure.EOF Then
0271 strDirectory = "../../Notes/"
0272 Else
0273 rsSecure.MoveFirst
0274 If rsSecure.Fields(0) <> Notes_Group_Name Then
0275 If rsSecure.Fields(0) = "Supervisions" Then
0276 strDirectory = "../../Secure_Jen/"
0277 Else
0278 If Notes_Group_Name = "Supervisions" Then
0279 strDirectory = "../../Notes/"
0280 End If
0281 End If
0282 End If
0283 End If
0284 End If
0285 FootNoteTimestamp = 0
0286 If Last_Changed_Timestamp > 0 Then 'This is either just a flag, or an actual timestamp
0287 If Last_Changed_Timestamp < 50000 Then
0288 Last_Changed_Timestamp = 50000000
0289 End If
0290 'Find latest Timestamp for links
0291 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 & "));")
0292 If Not rsLatestTimestamp.EOF Then
0293 rsLatestTimestamp.MoveFirst
0294 FootNoteTimestamp = rsLatestTimestamp.Fields(0).Value
0295 End If
0296 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 & "));")
0297 If FootNoteTimestamp = 0 Then
0298 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 & "));")
0299 If Not rsLatestTimestamp.EOF Then
0300 rsLatestTimestamp.MoveFirst
0301 FootNoteTimestamp = rsLatestTimestamp.Fields(0).Value
0302 End If
0303 End If
0304 Set rsLatestTimestamp = Nothing
0305 End If
0306 If Ref_Type = "N" Then
0307 NameRef = NameRef + 1
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=""" & NameRef & """></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
0504 DoCmd.OpenQuery ("Cross_Reference_Deletions")
0505If Test_Flag = True Then
0506 Debug.Print Now(); "Notes_Text_Format"; NoteID; Note_Ref; Last_Changed_Timestamp; sw2.EndTimer; "Milliseconds"; " Cross_Reference_Deletions"
0507 sw2.StartTimer
0508End If
0509 DoCmd.OpenQuery ("Cross_Reference_Additions")
0510If Test_Flag = True Then
0511 Debug.Print Now(); "Notes_Text_Format"; NoteID; Note_Ref; Last_Changed_Timestamp; sw2.EndTimer; "Milliseconds"; " Cross_Reference_Additions"
0512 sw2.StartTimer
0513End If
0514If IsMissing(strPrintable) Then
0515 Cross_Reference_Table_Open = False
0516 Set rsCross_Reference_Table = Nothing
0517 DoCmd.OpenQuery ("Cross_Reference_Idempotency_Zap")
0518End If
0519If Test_Flag = True Then
0520 Debug.Print Now(); "Notes_Text_Format"; NoteID; Note_Ref; Last_Changed_Timestamp; sw.EndTimer; "Milliseconds"
0521End If
0522If Test_Flag = True Then
0523 Set sw = Nothing
0524 Set sw2 = Nothing
0525End If
0526Set rst = Nothing
0527End 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: 119
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 'Numbered Lists
0039 Do While iListstart <> 0 And iListEnd <> 0
0040 iListstart = InStr(iListEnd, strStringTemp, Delimiter, vbBinaryCompare)
0041 If iListstart > 0 Then
0042 iListEnd = InStr(iListstart + 1, strStringTemp, Delimiter, vbBinaryCompare)
0043 End If
0044 If iListstart <> 0 And iListEnd <> 0 Then
0045 'Check for start-number over-ride
0046 '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"
0047 startTag = ""
0048 strFirstNumber = ""
0049 i = InStr(iListstart + 1, strStringTemp, "|1|")
0050 j = InStr(iListstart + 1, strStringTemp, "|0|")
0051 If Mid(strStringTemp, j + 2, 3) = "|1|" Then
0052 j = 0
0053 End If
0054 If j > 0 Then
0055 If i > 0 Then
0056 If j < i Then
0057 i = j
0058 End If
0059 Else
0060 i = j
0061 End If
0062 End If
0063 If i > iListEnd Then
0064 i = 0
0065 End If
0066 Len_strFirstNumber = 0
0067 If i > 0 Then
0068 If i - iListstart > 4 Then
0069 strFirstNumber = Mid(strStringTemp, iListstart + 4, i - iListstart - 4)
0070 Len_strFirstNumber = Len(strFirstNumber)
0071 If IsNumeric(Trim(strFirstNumber)) Then
0072 startTag = "start = """ & Trim(strFirstNumber) & """ "
0073 Else
0074 i = iListstart + 4
0075 strFirstNumber = ""
0076 Len_strFirstNumber = 0
0077 End If
0078 End If
0079 Else
0080 'Check to ensure the |1|'s haven't already been stolen by another numbered list!
0081 i = InStr(iListstart + 1, strStringTemp, "<li>")
0082 If i > iListEnd Then
0083 i = 0
0084 End If
0085 If i > 0 Then
0086 If i - iListstart > 4 Then
0087 strFirstNumber = Mid(strStringTemp, iListstart + 4, i - iListstart - 4)
0088 Len_strFirstNumber = Len(strFirstNumber)
0089 strFirstNumber = Replace(strFirstNumber, "</li>", "")
0090 If IsNumeric(Trim(strFirstNumber)) Then
0091 startTag = "start = """ & Trim(strFirstNumber) & """ "
0092 End If
0093 End If
0094 Else
0095 i = iListstart + 4
0096 End If
0097 End If
0098 endTag = ""
0099 strStringTemp = Left(strStringTemp, iListstart - 1) & "<ol " & startTag & "type=""" & Widget & """>" & Mid(strStringTemp, i, Len(strStringTemp))
0100 iListEnd = iListEnd - 4 + 13 + Len(startTag) - Len_strFirstNumber
0101 iNextBullet = InStr(iListstart + 1, strStringTemp, "|1|")
0102 Do While iNextBullet <> 0 And iNextBullet < iListEnd
0103 If iNextBullet <> 0 Then
0104 strStringTemp = Left(strStringTemp, iNextBullet - 1) & endTag & "<li>" & Mid(strStringTemp, iNextBullet + 3, Len(strStringTemp))
0105 iListEnd = iListEnd - 3 + Len(endTag) + 4
0106 End If
0107 endTag = "</li>"
0108 iNextBullet = InStr(iNextBullet + 1, strStringTemp, "|1|")
0109 Loop
0110 strStringTemp = Left(strStringTemp, iListEnd - 1) & endTag & "</ol>" & Mid(strStringTemp, iListEnd + 4, Len(strStringTemp))
0111 iListEnd = iListEnd - 4 + Len(endTag) + 5
0112 End If
0113 Loop
0114Next k
0115strStringTemp = Replace(strStringTemp, "|0|", "")
0116strStringTemp = Replace(strStringTemp, "<BR></li>", "</li>")
0117strStringTemp = Replace(strStringTemp, "<BR><li>", "<li>")
0118NumberedBullets = strStringTemp
0119End Function

Procedures Calling 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
0006Dim 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 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) > 30 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 - May 2020. 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