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 15 (9 items)

Replace_TimestampCode_Location_AssignmentControlCreateAuthorsWebPages
Regen_Book_Book_LinksRegen_Book_Paper_LinksRegen_Paper_Book_LinksRegen_Paper_Note_Links
Regen_Paper_Paper_Links...

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

Go to top of page



Source Code of: Code_Location_Assignment
Procedure Type: Public Sub
Module: Documentation
Lines of Code: 79
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Code_Location_Assignment()
0002'This Sub assigns Code locations to new procedures (recognised by not having Code Locations!
0003Dim rsTableToRead As Recordset
0004Dim rsTableToRead2 As Recordset
0005Dim rsTableToWrite As Recordset
0006Dim rsTableToWrite2 As Recordset
0007Dim This_Length As Long
0008Dim Total_Length As Long
0009Dim Max_Length As Long
0010Dim Next_Location As Integer
0011Dim iLocation As Integer
0012Dim Procedure_Name As String
0013Dim Filed_Away As Boolean
0014Max_Length = 500
0015iLocation = 1
0016Total_Length = 0
0017'Ready Code_Location for New Inserts
0018 Set rsTableToWrite = CurrentDb.OpenRecordset("Select Code_Location.* FROM Code_Location WHERE Code_Location.Code_Location = 0;")
0019'Find maximum used location
0020 Set rsTableToRead = CurrentDb.OpenRecordset("Select Max(Code_Location) FROM Code_Location;")
0021rsTableToRead.MoveFirst
0022Next_Location = rsTableToRead.Fields(0) + 1
0023'Read Procedures without Code_Locations
0024 Set rsTableToRead = CurrentDb.OpenRecordset("Select Procedure_Name, Lines, Code_Location FROM Code_Table WHERE Code_Location = 0 ORDER BY Procedure_Name;")
0025If rsTableToRead.EOF Then
0026 Exit Sub 'Nothing to do
0027End If
0028rsTableToRead.MoveFirst
0029'Read Available Locations
0030 Set rsTableToRead2 = CurrentDb.OpenRecordset("SELECT Code_Table.Code_Location, Sum(Code_Table.Lines) AS SumOfLines FROM Code_Table GROUP BY Code_Table.Code_Location HAVING (((Sum(Code_Table.Lines) + " & This_Length & ") < " & Max_Length & ") AND Code_Table.Code_Location <> 0) ORDER BY Sum(Code_Table.Lines) DESC;")
0031If rsTableToRead2.EOF Then
0032 Total_Length = 1000
0033Else
0034 rsTableToRead2.MoveFirst
0035 Total_Length = rsTableToRead2.Fields(1)
0036End If
0037Total_Length = Total_Length + This_Length
0038Do Until rsTableToRead.EOF
0039 Procedure_Name = rsTableToRead.Fields(0)
0040 This_Length = rsTableToRead.Fields(1)
0041 Filed_Away = False
0042 Do Until Filed_Away = True
0043 If This_Length + Total_Length > Max_Length Then
0044 Filed_Away = False
0045 'Read Code Locations with spare space
0046 Set rsTableToRead2 = CurrentDb.OpenRecordset("SELECT Code_Table.Code_Location, Sum(Code_Table.Lines) AS SumOfLines FROM Code_Table GROUP BY Code_Table.Code_Location HAVING (((Sum(Code_Table.Lines) + " & This_Length & ") < " & Max_Length & ") AND Code_Table.Code_Location <> 0) ORDER BY Sum(Code_Table.Lines) DESC;")
0047 If rsTableToRead2.EOF Then
0048 Total_Length = 0
0049 iLocation = Next_Location
0050 Next_Location = Next_Location + 1
0051 Filed_Away = True
0052 Else
0053 rsTableToRead2.MoveFirst
0054 iLocation = rsTableToRead2.Fields(0)
0055 Total_Length = rsTableToRead2.Fields(1)
0056 End If
0057 Else
0058 Filed_Away = True
0059 End If
0060 Loop
0061 Total_Length = Total_Length + This_Length
0062 'Add the record to Code_Location table
0063 rsTableToWrite.AddNew
0064 rsTableToWrite.Fields(0) = Procedure_Name
0065 rsTableToWrite.Fields(1) = iLocation
0066 rsTableToWrite.Update
0067 'Update record on Code_Table
0068 Set rsTableToWrite2 = CurrentDb.OpenRecordset("SELECT Code_Table.Procedure_Name, Code_Table.Code_Location FROM Code_Table WHERE Code_Table.Procedure_Name = """ & Procedure_Name & """;")
0069 rsTableToWrite2.Edit
0070 rsTableToWrite2.Fields(1) = iLocation
0071 rsTableToWrite2.Update
0072 'Read Next Record
0073 rsTableToRead.MoveNext
0074Loop
0075Set rsTableToWrite = Nothing
0076Set rsTableToWrite2 = Nothing
0077Set rsTableToRead = Nothing
0078Set rsTableToRead2 = Nothing
0079End Sub

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


Source Code of: Control
Procedure Type: Public Sub
Module: LazyLibrarian
Lines of Code: 11

Line-No. / Ref.Code Line
0001Public Sub Control()
0002Dim Tests As Integer
0003Tests = 2 'Parameterised
0004Test = 1
0005Do While Test <= Tests
0006 StartUp
0007 SortBooks
0008 LogStats
0009 Test = Test + 1
0010Loop
0011End Sub

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


Source Code of: CreateAuthorsWebPages
Procedure Type: Public Sub
Module: New Code
Lines of Code: 514
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub CreateAuthorsWebPages(Run_Type)
0002'This is a new module to generate the pages that list the Books and Papers associated with a particular Author.
0003'Called by WebpageGenAuthors
0004Dim fsoTextFile As FileSystemObject
0005Dim tsTextFile As TextStream
0006Dim rsTableToRead As Recordset
0007Dim rsAuthor_Letters As Recordset
0008Dim rsSurnames As Recordset
0009Dim rsTableControl As Recordset
0010Dim rsAuthorNarrative As Recordset
0011Dim strControlQuery As String
0012Dim strLine As String
0013Dim iTableColumns As Integer
0014Dim iFieldNo As Integer
0015Dim x As Integer
0016Dim i As Integer
0017Dim Author As String
0018Dim Author_Previous As String
0019Dim ObjectID As Integer
0020Dim strFileSuffix As String
0021Dim strFileBody As String
0022Dim StartTime As Double
0023Dim Latest_Author As String
0024Dim Latest_Title As String
0025Dim Latest_Pages As Long
0026Dim Latest_Medium As String
0027Dim strAuthor As String
0028Dim Surname As String
0029Dim qryString As String
0030Dim AuthorLink As String
0031Dim Time_Stamp As String
0032Dim Latest_Author_Letter As String
0033Dim Latest_Author_Letter_Saved As String
0034Dim RunTime As Double
0035Dim RunTime_Start As Double
0036Dim RunDate As Date
0037Dim TableElementWidth As Single
0038Dim Surname_Count As Integer
0039Dim iCount As Long
0040Dim Section As String
0041Dim iAuthor_Found As Integer
0042Dim Link_Count As Integer
0043Dim Link_1 As String
0044Dim Link_2 As String
0045Dim Link_3 As String
0046Dim Link_4 As String
0047Dim Link_5 As String
0048Dim Link_Authors As String
0049Dim strTable As String
0050Dim strDataQuery_Saved As String
0051Dim strAuthor_Narrative As String
0052Dim strAuthor_Name_Display As String
0053Dim iBook_Count As Integer
0054Dim iPaper_Count As Integer
0055Dim iCitation_Count As Integer
0056Dim iSynonym_Count As Integer
0057Dim Author_ID As Integer
0058Dim sw As StopWatch
0059Dim sw2 As StopWatch
0060'Test_Flag = True
0061If Test_Flag = True Then
0062 Set sw = New StopWatch
0063 Set sw2 = New StopWatch
0064 sw.StartTimer
0065End If
0066strDataQuery_Saved = strDataQuery
0067iCount = 0
0068Cross_Reference_Table_Open = False
0069Set rsCross_Reference_Table = Nothing
0070Set fsoTextFile = New FileSystemObject
0071strFolder = strOutputFolder
0072StartTime = Now()
0073Latest_Author_Letter_Saved = "*"
0074 OK = Convert_Webrefs("Author", "Full")
0075'Read the data for Books & Papers by Author
0076Set rsTableToRead = CurrentDb.OpenRecordset(strDataQuery)
0077RunTime_Start = Now()
0078If Not rsTableToRead.EOF Then
0079 rsTableToRead.MoveFirst
0080 iTableColumns = rsTableToRead.Fields.Count
0081 Latest_Author = rsTableToRead.Fields(0).Value
0082 Latest_Author_Letter_Saved = Left(rsTableToRead.Fields(0), 1)
0083 Latest_Title = rsTableToRead.Fields(2).Value & ""
0084 Latest_Pages = Nz(rsTableToRead.Fields(3).Value)
0085 Latest_Medium = rsTableToRead.Fields(iTableColumns - 1).Value & ""
0086 'Column 0 is the Author, Penultimate Column is the Object ID, the Last Column says whether it's a Book or a Paper
0087 Author_Previous = "" 'There is no Author ""
0088 strFileSuffix = ""
0089 strFileBody = ""
0090 Do Until rsTableToRead.EOF
0091 Author = rsTableToRead.Fields(0)
0092 ObjectID = Nz(rsTableToRead.Fields(iTableColumns - 2))
0093 If Author_Previous <> Author Then 'New Author
0094 Section = ""
0095 'Write the previous Footer (except first time)
0096 If Author_Previous <> "" Then
0097 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Footer"")) ORDER BY Website_Control.Line;"
0098 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0099 rsTableControl.MoveFirst
0100 Do While Not rsTableControl.EOF
0101 Time_Stamp = rsTableControl.Fields(0) & ""
0102 OK = Replace_Timestamp(Time_Stamp)
0103 tsTextFile.WriteLine Time_Stamp
0104 rsTableControl.MoveNext
0105 Loop
0106 If Test_Flag = True Then
0107 sw2.StartTimer
0108 End If
0109 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0110 If Test_Flag = True Then
0111 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " CopyToTransfer"
0112 Debug.Print Now(); strFileSuffix; sw.EndTimer; "Milliseconds"
0113 End If
0114 DoEvents
0115 If Test_Flag = True Then
0116 Stop
0117 sw.StartTimer
0118 End If
0119 iCount = iCount + 1
0120 Else
0121 If Test_Flag = True Then
0122 sw.StartTimer
0123 End If
0124 End If
0125 Author_Previous = Author
0126 strFileSuffix = strOutputFileShort & "_" & Author
0127 strFileBody = UCase(Left(Author, 1))
0128 'Create File
0129 If Test_Flag = True Then
0130 sw2.StartTimer
0131 End If
0132 Set tsTextFile = fsoTextFile.CreateTextFile(strOutputFolder & strFileBody & "\" & strFileSuffix & ".htm", True, True)
0133 'Referencing
0134 OK = Zap_Cross_References("A", Author, 0)
0135 'NameRef = 0
0136 If Test_Flag = True Then
0137 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " CreateTextFile"
0138 End If
0139 'Page Header
0140 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Header"")) ORDER BY Website_Control.Line;"
0141 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0142 rsTableControl.MoveFirst
0143 Do While Not rsTableControl.EOF
0144 strLine = rsTableControl.Fields(0) & ""
0145 x = InStr(1, strLine, "**LINK**")
0146 If x > 0 Then
0147 If Test_Flag = True Then
0148 sw2.StartTimer
0149 End If
0150 Link_Count = 0
0151 Link_1 = "" 'Author Narrative
0152 Link_2 = "" 'Other Author's with same Surname
0153 Link_3 = "" 'Citations
0154 Link_4 = "" 'Books
0155 Link_5 = "" 'Papers
0156 Link_Authors = ""
0157 strAuthor = rsTableToRead.Fields(0)
0158 'Read Author_Narrative, and various counts associated with this Author
0159 'As of 10/04/2020 I've decided not to be too fussy about timing issues, and take the counts from the Authors table, created the last time the Author's Summary was output
0160 strDataQuery = "SELECT Authors.Author_Narrative, Authors.Author_ID, Authors.Author_Name_Display, Authors.Author_Book_Count, Authors.Author_Paper_Count, Authors.Author_Citation_Count, Authors.Author_Synonym_Count, Authors.Author_Surname FROM Authors WHERE (((Authors.Author_Name)=""" & rsTableToRead.Fields(0) & """));"
0161 Set rsAuthorNarrative = CurrentDb.OpenRecordset(strDataQuery)
0162 If Not rsAuthorNarrative.EOF Then
0163 rsAuthorNarrative.MoveFirst
0164 strAuthor_Narrative = rsAuthorNarrative.Fields(0) & ""
0165 Author_ID = rsAuthorNarrative.Fields(1)
0166 strAuthor_Name_Display = rsAuthorNarrative.Fields(2) & ""
0167 iBook_Count = rsAuthorNarrative.Fields(3)
0168 iPaper_Count = rsAuthorNarrative.Fields(4)
0169 iCitation_Count = rsAuthorNarrative.Fields(5)
0170 iSynonym_Count = rsAuthorNarrative.Fields(6)
0171 Surname = rsAuthorNarrative.Fields(7) & ""
0172 Else
0173 strAuthor_Narrative = ""
0174 strAuthor_Name_Display = ""
0175 Author_ID = 0
0176 iBook_Count = 0
0177 iPaper_Count = 0
0178 iCitation_Count = 0
0179 iSynonym_Count = 0
0180 Surname = ""
0181 End If
0182 Set rsAuthorNarrative = Nothing
0183 'Author Narrative Link
0184 If strAuthor_Narrative <> "" Then
0185 Link_1 = "<A HREF = ""#Author_Narrative"">Author Narrative</A>"
0186 Link_Count = Link_Count + 1
0187 End If
0188 'Author Synonyms Link
0189 If iSynonym_Count > 1 Then
0190 Link_2 = "<A HREF = ""#Author_Synonyms"">Author Synonyms</A> (" & iSynonym_Count - 1 & ")"
0191 Link_Count = Link_Count + 1
0192 End If
0193 'Author Citations Link
0194 If iCitation_Count > 0 Then
0195 Link_3 = "<A HREF = ""#Author_Citations"">Author Citations</A> (" & iCitation_Count & ")"
0196 Link_Count = Link_Count + 1
0197 Else
0198 Link_3 = ""
0199 End If
0200 'Author Books Link
0201 If iBook_Count > 0 Then
0202 Link_4 = "<A HREF = ""#Author_Books"">Author's Books</A> (" & iBook_Count & ")"
0203 Link_Count = Link_Count + 1
0204 End If
0205 'Author Papers Link
0206 If iPaper_Count > 0 Then
0207 Link_5 = "<A HREF = ""#Author_Papers"">Author's Papers</A> (" & iPaper_Count & ")"
0208 Link_Count = Link_Count + 1
0209 End If
0210 strTable = "<CENTER><TABLE class = ""Bridge"" WIDTH=" & Link_Count * 200 & "><tr>"
0211 If Link_1 <> "" Then
0212 strTable = strTable & "<td>" & Link_1 & "</td>"
0213 End If
0214 If Link_2 <> "" Then
0215 strTable = strTable & "<td>" & Link_2 & "</td>"
0216 End If
0217 If Link_3 <> "" Then
0218 strTable = strTable & "<td>" & Link_3 & "</td>"
0219 End If
0220 If Link_4 <> "" Then
0221 strTable = strTable & "<td>" & Link_4 & "</td>"
0222 End If
0223 If Link_5 <> "" Then
0224 strTable = strTable & "<td>" & Link_5 & "</td>"
0225 End If
0226 strTable = strTable & "</tr></TABLE></CENTER>"
0227 strLine = Left(strLine, x - 1) & strTable & Link_Authors & Mid(strLine, x + 8, Len(strLine))
0228 If Test_Flag = True Then
0229 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " Author Counts"
0230 End If
0231 End If
0232 x = InStr(1, strLine, "**AUTHOR**")
0233 If x > 0 Then
0234 'Add the Author
0235 If Test_Flag = True Then
0236 sw2.StartTimer
0237 End If
0238 strLine = Left(strLine, x - 1) & "<u><b>" & strAuthor_Name_Display & "</b></u><br><br>[" & rsTableToRead.Fields(0) & "]" & Mid(strLine, x + 10, Len(strLine))
0239 tsTextFile.WriteLine strLine
0240 strLine = "<p>This Page provides links to the Books and Papers (including Book Chapters, where I have itemised these) by this Author contained in my collection. Clearly, there may be many more works in the Author's oeuvre that I don't possess. "
0241 If Link_1 <> "" Then
0242 strLine = strLine & "An introductory note on the Author appears first. "
0243 End If
0244 If iSynonym_Count > 1 Then
0245 strLine = strLine & "In case of misclassification, or ambiguous classification, authors of the same surname as this Author are listed for easy access. "
0246 End If
0247 strLine = strLine & "If any (other) Authors, Books, Papers or Notes in my collection cite this Author, a table of links is provided before the list of the Author's works. Scroll down or follow the links above. </p>"
0248 tsTextFile.WriteLine strLine
0249 strLine = ""
0250 'Add the Author Narrative (if any)
0251 If strAuthor_Narrative <> "" Then
0252 strLine = "<a name=""Author_Narrative""></a>"
0253 tsTextFile.WriteLine strLine
0254 strLine = "<hr>" & "|Colour_1|<b>Author Narrative</b>: " & strAuthor_Narrative
0255 'Need to format ...
0256 strLine = Remove_Dummy_Ref(strLine)
0257 strLine = WebEncode(strLine)
0258 Clear_Colour_Usage
0259 OK = Mark_Colours(strLine)
0260 OK = Reference_FootNotes("A", Author_ID, strLine)
0261 OK = Reference_Notes(strLine, "A", Author_ID, 0, 2, "Abstract_Direct") 'Replace the Notes References by hyperlinks
0262 OK = Reference_Papers(strLine, "A", Author_ID, 0, 2) 'Replace the Papers References by hyperlinks
0263 OK = Reference_Author(strLine, "A", Author_ID, 0, 2) 'Replace the Author References by hyperlinks
0264 OK = Reference_Books(strLine, "A", Author_ID, 0, 2) 'Replace the Books References by hyperlinks
0265 strLine = ReplaceCode(strLine, Chr(13) & Chr(10), "<BR>")
0266 strLine = NumberedBullets(strLine)
0267 strLine = Bullets(strLine)
0268 OK = Reference_Webrefs(strLine, "A", Author_ID, 0)
0269 tsTextFile.WriteLine strLine
0270 strLine = "<HR><B><U>Text Colour Conventions</U></B><OL TYPE=""1"">"
0271 For i = 0 To 19
0272 If Colour_Table(i, 4) = "1" Then
0273 strLine = strLine & "<LI><FONT COLOR = """ & Colour_Table(i, 1) & """>" & Colour_Table(i, 2) & "</FONT>: " & Colour_Table(i, 3) & "</li>"
0274 End If
0275 Next i
0276 strLine = strLine & "</OL>"
0277 'Log Referencing Changes
0278 If Full_Regen = False Then
0279 DoCmd.OpenQuery ("Cross_Reference_Changes_Deletions_Add")
0280 DoCmd.OpenQuery ("Cross_Reference_Changes_Additions_Add")
0281 If Test_Flag = True Then
0282 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " Cross_Reference_Changes"
0283 End If
0284 End If
0285 tsTextFile.WriteLine strLine
0286 End If
0287 If Test_Flag = True Then
0288 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " Author_Narrative"
0289 End If
0290 'Write links to authors with the same surname
0291 If Test_Flag = True Then
0292 sw2.StartTimer
0293 End If
0294 If iSynonym_Count > 1 Then
0295 qryString = "SELECT Authors.Author_Name, Authors.Author_Name_Display FROM Authors WHERE (((Authors.Author_Surname) = """ & Surname & """)) ORDER BY Authors.Author_Name;"
0296 Set rsSurnames = CurrentDb.OpenRecordset(qryString)
0297 rsSurnames.MoveFirst
0298 strLine = "<a name=""Author_Synonyms""></a>"
0299 tsTextFile.WriteLine strLine
0300 tsTextFile.WriteLine "<hr><br><h3>Links to other Authors with Surnames <U>" & Surname & "</U></h3>"
0301 tsTextFile.WriteLine "<center><TABLE class = ""Bridge"" WIDTH=900>"
0302 If iSynonym_Count > 6 Then
0303 TableElementWidth = 20
0304 Else
0305 If rsSurnames.RecordCount = 1 Then
0306 TableElementWidth = 100
0307 Else
0308 TableElementWidth = Round(100 / (rsSurnames.RecordCount - iAuthor_Found), 1)
0309 End If
0310 End If
0311 Surname_Count = 0
0312 Do While Not rsSurnames.EOF
0313 AuthorLink = rsSurnames.Fields(0).Value
0314 If AuthorLink <> strAuthor Then
0315 If Surname_Count = 0 Then
0316 tsTextFile.WriteLine "<TR>"
0317 End If
0318 Surname_Count = Surname_Count + 1
0319 AuthorLink = "<A HREF = ""Author_" & AuthorLink & ".htm"">" & AuthorLink & "</A>"
0320 strLine = "<TD WIDTH=""" & TableElementWidth & "%"">" & AuthorLink & "</TD>"
0321 tsTextFile.WriteLine strLine
0322 If Surname_Count = 5 Then
0323 Surname_Count = 0
0324 strLine = "</TR>"
0325 tsTextFile.WriteLine strLine
0326 End If
0327 End If
0328 rsSurnames.MoveNext
0329 Loop
0330 If iSynonym_Count > 6 Then
0331 If Surname_Count <> 0 Then
0332 For i = Surname_Count + 1 To 5
0333 strLine = "<TD WIDTH=""" & TableElementWidth & "%"">&nbsp;</TD>"
0334 tsTextFile.WriteLine strLine
0335 Next i
0336 End If
0337 End If
0338 If strLine <> "</TR>" Then
0339 tsTextFile.WriteLine "</TR>"
0340 End If
0341 tsTextFile.WriteLine "</TABLE></center>"
0342 End If
0343 Set rsSurnames = Nothing
0344 If Test_Flag = True Then
0345 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " Author Synonyms"
0346 End If
0347 Else
0348 tsTextFile.WriteLine strLine
0349 End If
0350 rsTableControl.MoveNext
0351 Loop
0352 'Add the list of Authors, Books, Papers & Notes referencing this Author
0353 If Test_Flag = True Then
0354 sw2.StartTimer
0355 End If
0356 strLine = "<a name=""Author_Citations""></a>"
0357 tsTextFile.WriteLine strLine
0358 OK = AddCitations_List("Author", Author_ID, tsTextFile, "Non-Print")
0359 If Test_Flag = True Then
0360 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " AddCitations_List"
0361 End If
0362 'Read Table-Control for rows
0363 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Table_Row"")) ORDER BY Website_Control.Line;"
0364 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0365 End If
0366 'Table Row
0367 rsTableControl.MoveFirst
0368 Do While Not rsTableControl.EOF
0369 'Add the headings
0370 If Latest_Medium <> Section Then
0371 If Section <> "" Then
0372 tsTextFile.WriteLine "</TABLE><br>"
0373 Else
0374 tsTextFile.WriteLine "<br><hr><br><center>"
0375 End If
0376 strLine = "<a name=""Author_" & Latest_Medium & "s""></a>"
0377 tsTextFile.WriteLine strLine
0378 Section = Latest_Medium
0379 tsTextFile.WriteLine "<TABLE class = ""ReadingList"" WIDTH=950>"
0380 tsTextFile.WriteLine "<h3>Author's " & Latest_Medium & "s In My Possession</h3>"
0381 'Table Column Headings
0382 rsTableControl.MoveFirst
0383 Do While Not rsTableControl.EOF
0384 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0385 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0386 'Note: Fields start at 0, but the first one in the query is the Author, and the last one is the Paper ID
0387 If iFieldNo > 0 And iFieldNo <= iTableColumns - 2 Then
0388 tsTextFile.WriteLine "<B> " & rsTableToRead.Fields(iFieldNo).Name & "</B>"
0389 End If
0390 Else
0391 tsTextFile.WriteLine rsTableControl.Fields(0) & ""
0392 End If
0393 rsTableControl.MoveNext
0394 Loop
0395 rsTableControl.MoveFirst
0396 End If
0397 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0398 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0399 If iFieldNo > 0 And iFieldNo <= iTableColumns - 2 Then
0400 If Len(rsTableToRead.Fields(iFieldNo) & "") = 0 Then
0401 strLine = "&nbsp;"
0402 Else
0403 Select Case rsTableToRead.Fields(iFieldNo).Name
0404 Case "Title"
0405 If rsTableToRead.Fields(5).Value = "." Then
0406 strLine = rsTableToRead.Fields(iFieldNo)
0407 Else
0408 If rsTableToRead.Fields(iTableColumns - 1) = "Paper" Then
0409 strLine = "<A HREF = ""../../PaperSummaries/PaperSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/PaperSummary_" & ObjectID & ".htm"">" & rsTableToRead.Fields(iFieldNo) & "</A>"
0410 Else
0411 strLine = "<A HREF = ""../../BookSummaries/BookSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/BookSummary_" & ObjectID & ".htm"">" & rsTableToRead.Fields(iFieldNo) & "</A>"
0412 End If
0413 End If
0414 Case "Further Information"
0415 If rsTableToRead.Fields(iFieldNo).Value = "." Then
0416 If rsTableToRead.Fields(iTableColumns - 1) = "Paper" Then
0417 strLine = "<A HREF = ""../../PaperSummaries/PaperSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/PaperSummary_" & ObjectID & ".htm"">Paper</A>"
0418 Else
0419 strLine = "<A HREF = ""../../BookSummaries/BookSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/BookSummary_" & ObjectID & ".htm"">Book</A>"
0420 End If
0421 Else
0422 If rsTableToRead.Fields(iTableColumns - 1) = "Paper" Then
0423 strLine = "<A HREF = ""../../Abstracts/Abstract_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/Abstract_" & ObjectID & ".htm"">Paper Abstract</A>"
0424 Else
0425 strLine = "<A HREF = ""../../BookSummaries/BookSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/BookPaperAbstracts/BookPaperAbstracts_" & ObjectID & ".htm"">Book Abstract</A>"
0426 End If
0427 strLine = strLine & rsTableToRead.Fields(iFieldNo)
0428 End If
0429 Case Else
0430 strLine = rsTableToRead.Fields(iFieldNo)
0431 End Select
0432 End If
0433 strLine = ReplaceCode(strLine, Chr(13) & Chr(10), "<BR>")
0434 tsTextFile.WriteLine strLine
0435 End If
0436 Else
0437 tsTextFile.WriteLine rsTableControl.Fields(0) & ""
0438 End If
0439 rsTableControl.MoveNext
0440 Loop
0441 rsTableToRead.MoveNext
0442 If Not rsTableToRead.EOF Then
0443 Latest_Author = rsTableToRead.Fields(1).Value & ""
0444 Latest_Title = rsTableToRead.Fields(2).Value & ""
0445 Latest_Pages = Nz(rsTableToRead.Fields(3).Value)
0446 Latest_Medium = rsTableToRead.Fields(iTableColumns - 1).Value & ""
0447 If Run_Type = "Regen_Letters" Then
0448 Latest_Author_Letter = Left(Author, 1)
0449 If Latest_Author_Letter <> Latest_Author_Letter_Saved Then
0450 RunTime = Now() - RunTime_Start
0451 RunTime = RunTime * 24 * 60
0452 RunTime = Round(RunTime, 1)
0453 RunDate = Now()
0454 'Update the control-table
0455 Set rsAuthor_Letters = CurrentDb.OpenRecordset("Select Author_Letter, Latest_Author_Letter_Update, Time_To_Regenerate FROM Author_Letters WHERE Author_Letter = """ & Latest_Author_Letter_Saved & """;")
0456 If Not rsAuthor_Letters.EOF Then
0457 rsAuthor_Letters.MoveFirst
0458 rsAuthor_Letters.Edit
0459 rsAuthor_Letters.Fields(1) = RunDate
0460 rsAuthor_Letters.Fields(2) = RunTime
0461 rsAuthor_Letters.Update
0462 End If
0463 Latest_Author_Letter_Saved = Latest_Author_Letter
0464 RunTime_Start = Now()
0465 Set rsAuthor_Letters = Nothing
0466 End If
0467 End If
0468 End If
0469 Loop
0470 'Write the Last Footer
0471 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Footer"")) ORDER BY Website_Control.Line;"
0472 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0473 rsTableControl.MoveFirst
0474 Do While Not rsTableControl.EOF
0475 Time_Stamp = rsTableControl.Fields(0) & ""
0476 OK = Replace_Timestamp(Time_Stamp)
0477 tsTextFile.WriteLine Time_Stamp
0478 rsTableControl.MoveNext
0479 Loop
0480 If Run_Type = "Regen_Letters" Then
0481 RunTime = Now() - RunTime_Start
0482 RunTime = RunTime * 24 * 60
0483 RunTime = Round(RunTime, 1)
0484 RunDate = Now()
0485 'Update the control-table
0486 Set rsAuthor_Letters = CurrentDb.OpenRecordset("Select Author_Letter, Latest_Author_Letter_Update, Time_To_Regenerate FROM Author_Letters WHERE Author_Letter = """ & Latest_Author_Letter_Saved & """;")
0487 If Not rsAuthor_Letters.EOF Then
0488 rsAuthor_Letters.MoveFirst
0489 rsAuthor_Letters.Edit
0490 rsAuthor_Letters.Fields(1) = RunDate
0491 rsAuthor_Letters.Fields(2) = RunTime
0492 rsAuthor_Letters.Update
0493 End If
0494 Set rsAuthor_Letters = Nothing
0495 End If
0496 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0497 iCount = iCount + 1
0498End If
0499Set rsAuthorNarrative = Nothing
0500Set rsTableToRead = Nothing
0501Set rsAuthor_Letters = Nothing
0502Set rsSurnames = Nothing
0503Set rsTableControl = Nothing
0504Cross_Reference_Table_Open = False
0505Set rsCross_Reference_Table = Nothing
0506 DoCmd.OpenQuery ("Cross_Reference_Idempotency_Zap")
0507If Test_Flag = True Then
0508 Set sw = Nothing
0509 Set sw2 = Nothing
0510End If
0511If automatic_processing <> "Yes" Then
0512 MsgBox strOutputFile & "Author to Book / Papers Links Creation Complete, in " & Round((Now() - StartTime) * 24 * 60, 1) & " minutes. " & iCount & " pages output.", vbOKOnly, "Create Authors Web Pages"
0513End If
0514End Sub

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


Source Code of: Regen_Book_Book_Links
Procedure Type: Public Sub
Module: New Code
Lines of Code: 36
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Regen_Book_Book_Links()
0002Dim strControlQuery As String
0003Dim strLine As String
0004Dim rsTableToRead As Recordset
0005Dim rsBookBookLinks As Recordset
0006Dim x As Long
0007Dim Y As Long
0008Dim iBookID As Integer
0009'Read Book records
0010 strControlQuery = "SELECT Books.ID1, Books.[Author & Title], Books.Abstract, Books.Comments FROM Books ORDER BY Books.Author;"
0011Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0012rsTableToRead.MoveFirst
0013'Ready the Book_Book_Links Table
0014 DoCmd.RunSQL ("DELETE Book_Book_Links.* FROM Book_Book_Links;")
0015 strControlQuery = "SELECT Book_Book_Links.* FROM Book_Book_Links;"
0016Set rsBookBookLinks = CurrentDb.OpenRecordset(strControlQuery)
0017'Regenerate the Book_Book_Links Table
0018Do While Not rsTableToRead.EOF
0019 strLine = rsTableToRead.Fields(2) & " " & rsTableToRead.Fields(3)
0020 x = 1
0021 x = InStr(x, strLine, "+B")
0022 Do While x > 0
0023 Y = InStr(x + 1, strLine, "B+")
0024 iBookID = Mid(strLine, x + 2, Y - x - 2)
0025 'Add the Book_Book_Links link
0026 rsBookBookLinks.AddNew
0027 rsBookBookLinks!Book_ID1 = rsTableToRead.Fields(0)
0028 rsBookBookLinks!Book_Author_Title = rsTableToRead.Fields(1)
0029 rsBookBookLinks!Book_ID = iBookID
0030 rsBookBookLinks![Timestamp] = Now()
0031 rsBookBookLinks.Update
0032 x = InStr(Y + 1, strLine, "+B")
0033 Loop
0034 rsTableToRead.MoveNext
0035Loop
0036End Sub

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


Source Code of: Regen_Book_Paper_Links
Procedure Type: Public Sub
Module: New Code
Lines of Code: 42
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Regen_Book_Paper_Links()
0002Dim strControlQuery As String
0003Dim strLine As String
0004Dim rsTableToRead As Recordset
0005Dim rsBookPaperLinks As Recordset
0006Dim x As Long
0007Dim Y As Long
0008Dim iPaperID As Integer
0009'Read Book records
0010 strControlQuery = "SELECT Books.ID1, Books.[Author & Title], Books.Abstract, Books.Comments FROM Books ORDER BY Books.Author;"
0011Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0012rsTableToRead.MoveFirst
0013'Ready the Book_Paper_Links Table
0014 DoCmd.RunSQL ("DELETE Book_Paper_Links.* FROM Book_Paper_Links;")
0015 strControlQuery = "SELECT Book_Paper_Links.* FROM Book_Paper_Links;"
0016Set rsBookPaperLinks = CurrentDb.OpenRecordset(strControlQuery)
0017'Regenerate the Book_Paper_Links Table
0018Do While Not rsTableToRead.EOF
0019 strLine = rsTableToRead.Fields(2) & " " & rsTableToRead.Fields(3)
0020 x = 1
0021 x = InStr(x, strLine, "+P")
0022 Do While x > 0
0023 Y = InStr(x + 1, strLine, "P+")
0024 If Y < x + 2 Then
0025 Y = x + 2
0026 Else
0027 If (Y - x - 2) <> 0 Then 'Watch out for +PP+
0028 iPaperID = Mid(strLine, x + 2, Y - x - 2)
0029 'Add the Book_Paper_Links link
0030 rsBookPaperLinks.AddNew
0031 rsBookPaperLinks!Book_ID1 = rsTableToRead.Fields(0)
0032 rsBookPaperLinks!Book_Author_Title = rsTableToRead.Fields(1)
0033 rsBookPaperLinks!Paper_ID = iPaperID
0034 rsBookPaperLinks![Timestamp] = Now()
0035 rsBookPaperLinks.Update
0036 End If
0037 End If
0038 x = InStr(Y + 1, strLine, "+P")
0039 Loop
0040 rsTableToRead.MoveNext
0041Loop
0042End Sub

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


Source Code of: Regen_Paper_Book_Links
Procedure Type: Public Sub
Module: New Code
Lines of Code: 45
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Regen_Paper_Book_Links()
0002Dim strControlQuery As String
0003Dim strLine As String
0004Dim rsTableToRead As Recordset
0005Dim rsPaperBookLinks As Recordset
0006Dim x As Long
0007Dim Y As Long
0008Dim iBookID As Integer
0009'Read Paper records
0010 strControlQuery = "SELECT Papers.ID, Papers.Author, Papers.Title, Papers.Abstract, Papers.Comments FROM Papers ORDER BY Papers.Author;"
0011Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0012rsTableToRead.MoveFirst
0013'Ready the Paper_Book_Links Table
0014 DoCmd.RunSQL ("DELETE Paper_Book_Links.* FROM Paper_Book_Links;")
0015 strControlQuery = "SELECT Paper_Book_Links.* FROM Paper_Book_Links;"
0016Set rsPaperBookLinks = CurrentDb.OpenRecordset(strControlQuery)
0017'Regenerate the Paper_Book_Links Table
0018Do While Not rsTableToRead.EOF
0019 strLine = rsTableToRead.Fields(3) & " " & rsTableToRead.Fields(4)
0020 x = 1
0021 x = InStr(x, strLine, "+B")
0022 Do While x > 0
0023 Y = InStr(x + 1, strLine, "B+")
0024 If Y > 0 And (Y - x < 10) Then
0025 If IsNumeric(Mid(strLine, x + 2, Y - x - 2)) Then
0026 iBookID = Mid(strLine, x + 2, Y - x - 2)
0027 'Add the Paper_Book_Links link
0028 rsPaperBookLinks.AddNew
0029 rsPaperBookLinks!Paper_ID = rsTableToRead.Fields(0)
0030 rsPaperBookLinks!Paper_Author = rsTableToRead.Fields(1)
0031 rsPaperBookLinks!Paper_Title = rsTableToRead.Fields(2)
0032 rsPaperBookLinks!Book_ID = iBookID
0033 rsPaperBookLinks![Timestamp] = Now()
0034 rsPaperBookLinks.Update
0035 x = InStr(Y + 1, strLine, "+B")
0036 Else
0037 x = InStr(x + 1, strLine, "+B")
0038 End If
0039 Else
0040 x = InStr(x + 1, strLine, "+B")
0041 End If
0042 Loop
0043 rsTableToRead.MoveNext
0044Loop
0045End Sub

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


Source Code of: Regen_Paper_Note_Links
Procedure Type: Public Sub
Module: New Code
Lines of Code: 146
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Regen_Paper_Note_Links()
0002'This Process maintains the Paper_Note_Links table, which records which Papers reference which Notes ...
0003'This is in contrast to the Regen_Note_Paper_Links Process which maintains the Note_Paper_Links table, which records which Notes reference which Papers ....
0004'Some day, I ought to combine these two tables ....
0005Dim strControlQuery As String
0006Dim strLine As String
0007Dim rsTableToRead As Recordset
0008Dim rsPaperNoteLinks As Recordset
0009Dim x As Long
0010Dim Y As Long
0011Dim z As Long
0012Dim i As Long
0013Dim TheWord As String
0014Dim rsNoteID As Recordset
0015Dim iNoteID As Integer
0016'Read Paper records
0017 strControlQuery = "SELECT Papers.ID, Papers.Author, Papers.Title, Papers.Abstract, Papers.Comments FROM Papers ORDER BY Papers.Author;"
0018Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0019'Ready the Paper_Note_Links Table
0020 DoCmd.RunSQL ("DELETE Paper_Note_Links.* FROM Paper_Note_Links;")
0021 strControlQuery = "SELECT Paper_Note_Links.* FROM Paper_Note_Links;"
0022Set rsPaperNoteLinks = CurrentDb.OpenRecordset(strControlQuery)
0023'Regenerate the Paper_Note_Links Table
0024'new-style Links
0025rsTableToRead.MoveFirst
0026Do While Not rsTableToRead.EOF
0027 strLine = rsTableToRead.Fields(3) & " " & rsTableToRead.Fields(4)
0028 x = 1
0029 x = InStr(x, strLine, "++")
0030 Do While x > 0
0031 Y = InStr(x + 1, strLine, "++")
0032 If Y > 0 Then
0033 If Y = x + 1 Then
0034 'Check this is the "++++" case where we have to look up the reference
0035 If Mid(strLine, x, 4) = "++++" Then
0036 'Find the key-word(s)
0037 If Mid(strLine, x - 1, 1) = " " Then
0038 i = FindWord(strLine, x - 1, "]")
0039 TheWord = Mid(strLine, i, x - 1 - i)
0040 Else
0041 i = FindWord(strLine, x, "]")
0042 TheWord = Mid(strLine, i, x - i)
0043 End If
0044 If Right(TheWord, 1) = "]" Then
0045 TheWord = Mid(TheWord, 2, Len(TheWord) - 2)
0046 End If
0047 'Find the Note ID. NB uses the Note_Alternates table!
0048 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 & """));")
0049 If rsNoteID.EOF Then
0050 iNoteID = 1256 'The "dud links" Note!
0051 Else
0052 rsNoteID.MoveFirst
0053 iNoteID = rsNoteID.Fields(0)
0054 End If
0055 Set rsNoteID = Nothing
0056 strLine = Left(strLine, x + 1) & iNoteID & Mid(strLine, x + 2)
0057 Y = Y + 1 + Len(iNoteID)
0058 End If
0059 Else
0060 If IsNumeric(Mid(strLine, x + 2, Y - x - 2)) Then
0061 iNoteID = Mid(strLine, x + 2, Y - x - 2)
0062 Else
0063 iNoteID = 0
0064 End If
0065 End If
0066 If iNoteID > 0 Then
0067 'Add the Paper_Note_Links link ... but need to check for duplicates!
0068 rsPaperNoteLinks.AddNew
0069 rsPaperNoteLinks!Paper_ID = rsTableToRead.Fields(0)
0070 rsPaperNoteLinks!Paper_Author = rsTableToRead.Fields(1)
0071 rsPaperNoteLinks!Paper_Title = rsTableToRead.Fields(2)
0072 rsPaperNoteLinks!Note_ID = iNoteID
0073 rsPaperNoteLinks![Timestamp] = Now()
0074 rsPaperNoteLinks.Update
0075 Else
0076 Y = x + 1
0077 End If
0078 Else
0079 Y = x + 1
0080 End If
0081 x = InStr(Y + 1, strLine, "++")
0082 Loop
0083 rsTableToRead.MoveNext
0084Loop
0085'Old-style Links
0086rsTableToRead.MoveFirst
0087Do While Not rsTableToRead.EOF
0088 strLine = rsTableToRead.Fields(3) & " " & rsTableToRead.Fields(4)
0089 x = 1
0090 x = InStr(x, strLine, "+N")
0091 Do While x > 0
0092 Y = InStr(x + 1, strLine, "N+")
0093 If Y > 0 Then
0094 If Y = x + 2 Then
0095 'Check this is the "+NN+" case where we have to look up the reference
0096 If Mid(strLine, x, 4) = "+NN+" Then
0097 'Find the key-word(s)
0098 If Mid(strLine, x - 1, 1) = " " Then
0099 i = FindWord(strLine, x - 1, "]")
0100 TheWord = Mid(strLine, i, x - 1 - i)
0101 Else
0102 i = FindWord(strLine, x, "]")
0103 TheWord = Mid(strLine, i, x - i)
0104 End If
0105 If Right(TheWord, 1) = "]" Then
0106 TheWord = Mid(TheWord, 2, Len(TheWord) - 2)
0107 End If
0108 'Find the Note ID. NB uses the Note_Alternates table!
0109 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 & """));")
0110 If rsNoteID.EOF Then
0111 iNoteID = 1256 'The "dud links" Note!
0112 Else
0113 rsNoteID.MoveFirst
0114 iNoteID = rsNoteID.Fields(0)
0115 End If
0116 Set rsNoteID = Nothing
0117 strLine = Left(strLine, x + 1) & iNoteID & Mid(strLine, x + 2)
0118 Y = Y + 1 + Len(iNoteID)
0119 End If
0120 Else
0121 'Check for Section Reference, and exclude it
0122 z = InStr(x + 1, strLine, "#")
0123 If z > 0 And z < Y Then
0124 iNoteID = Mid(strLine, x + 2, z - x - 2)
0125 Else
0126 iNoteID = Replace(Mid(strLine, x + 2, Y - x - 2), "NP", "") 'Changed 24/07/2021
0127 End If
0128 End If
0129 If iNoteID > 0 Then
0130 'Add the Paper_Note_Links link ... but need to check for duplicates!
0131 rsPaperNoteLinks.AddNew
0132 rsPaperNoteLinks!Paper_ID = rsTableToRead.Fields(0)
0133 rsPaperNoteLinks!Paper_Author = rsTableToRead.Fields(1)
0134 rsPaperNoteLinks!Paper_Title = rsTableToRead.Fields(2)
0135 rsPaperNoteLinks!Note_ID = iNoteID
0136 rsPaperNoteLinks![Timestamp] = Now()
0137 rsPaperNoteLinks.Update
0138 End If
0139 Else
0140 Y = x + 1
0141 End If
0142 x = InStr(Y + 1, strLine, "+N")
0143 Loop
0144 rsTableToRead.MoveNext
0145Loop
0146End Sub

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


Source Code of: Regen_Paper_Paper_Links
Procedure Type: Public Sub
Module: New Code
Lines of Code: 43
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Regen_Paper_Paper_Links()
0002Dim strControlQuery As String
0003Dim strLine As String
0004Dim rsTableToRead As Recordset
0005Dim rsPaperPaperLinks As Recordset
0006Dim x As Long
0007Dim Y As Long
0008Dim iPaperID As Integer
0009'Read Paper records
0010 strControlQuery = "SELECT Papers.ID, Papers.Author, Papers.Title, Papers.Abstract, Papers.Comments FROM Papers ORDER BY Papers.Author;"
0011Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0012rsTableToRead.MoveFirst
0013'Ready the Paper_Paper_Links Table
0014 DoCmd.RunSQL ("DELETE Paper_Paper_Links.* FROM Paper_Paper_Links;")
0015 strControlQuery = "SELECT Paper_Paper_Links.* FROM Paper_Paper_Links;"
0016Set rsPaperPaperLinks = CurrentDb.OpenRecordset(strControlQuery)
0017'Regenerate the Paper_Paper_Links Table
0018Do While Not rsTableToRead.EOF
0019 strLine = rsTableToRead.Fields(3) & " " & rsTableToRead.Fields(4)
0020 x = 1
0021 x = InStr(x, strLine, "+P")
0022 Do While x > 0
0023 Y = InStr(x + 1, strLine, "P+")
0024 If Y > 0 Then
0025 If IsNumeric(Mid(strLine, x + 2, Y - x - 2)) Then
0026 iPaperID = Mid(strLine, x + 2, Y - x - 2)
0027 'Add the Paper_Paper_Links link
0028 rsPaperPaperLinks.AddNew
0029 rsPaperPaperLinks!Paper_ID = rsTableToRead.Fields(0)
0030 rsPaperPaperLinks!Paper_Author = rsTableToRead.Fields(1)
0031 rsPaperPaperLinks!Paper_Title = rsTableToRead.Fields(2)
0032 rsPaperPaperLinks!Paper_ID2 = iPaperID
0033 rsPaperPaperLinks![Timestamp] = Now()
0034 rsPaperPaperLinks.Update
0035 End If
0036 Else
0037 Y = x + 2
0038 End If
0039 x = InStr(Y + 1, strLine, "+P")
0040 Loop
0041 rsTableToRead.MoveNext
0042Loop
0043End Sub

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


Source Code of: Replace_Timestamp
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 12

Line-No. / Ref.Code Line
0001Public Function Replace_Timestamp(strText)
0002Dim strText_Local As String
0003Dim strTimestampFull As String
0004If Len(strText) = 0 Then
0005 Replace_Timestamp = "Not Found"
0006 Exit Function
0007End If
0008strText_Local = strText
0009strTimestampFull = "<time datetime=""" & Year(Now()) & "-" & Right(Month(Now()) + 100, 2) & "-" & Right(Day(Now()) + 100, 2) & "T" & Right(Hour(Now) + 100, 2) & ":" & Right(Minute(Now()) + 100, 2) & """ pubdate>" & Now() & "</time>"
0010strText_Local = Replace(strText_Local, "**NOW**", strTimestampFull)
0011strText = strText_Local
0012End Function

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


© Theo Todman, June 2007 - July 2026. 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