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

CreateBookPaperAbstractsWebPagesCreatePapersToBooksWebPagesCreatePapersToNotesWebPagesFind_Book_Paper_Links

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

Go to top of page




Source Code of: CreateBookPaperAbstractsWebPages
Procedure Type: Public Sub
Module: New Code
Lines of Code: 730
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub CreateBookPaperAbstractsWebPages()
0002'This is a new module to generate the pages that list the Abstracts of all the Papers associated with a particular Book.
0003'It was based on Sub CreatePapersToBooksWebPages
0004Dim fsoTextFile As FileSystemObject
0005Dim tsTextFile As TextStream
0006Dim rsTableToRead As Recordset
0007Dim rsTableToRead2 As Recordset
0008Dim rsTableToRead3 As Recordset
0009Dim rsTableControl As Recordset
0010Dim rsCitings As Recordset
0011Dim rsColourCheck As Recordset
0012Dim rsNote As Recordset
0013Dim rsNote2 As Recordset
0014Dim strControlQuery As String
0015Dim strLine As String
0016Dim iTableColumns As Integer
0017Dim x As Integer
0018Dim z As String
0019Dim i As Integer
0020Dim j As Integer
0021Dim BookID As Integer
0022Dim BookID_Previous As Integer
0023Dim PaperID As Integer
0024Dim strFileSuffix As String
0025Dim strFileSuffix_Previous As String
0026Dim strFileBody As String
0027Dim strFileBody_Previous As String
0028Dim StartTime As Double
0029Dim RunStartTime As Date
0030Dim Temp_Book_ID As Long
0031Dim Regen_Books_Only As String
0032Dim strAbstract As String
0033Dim strText As String
0034Dim strComment As String
0035Dim iDepth As Integer
0036Dim Print_The_First_Paper As String
0037Dim PaperTitle As String
0038Dim PaperRef As Integer
0039Dim qryString As String
0040Dim Regen_Blurb As String
0041Dim First_Book_To_Regen As String
0042Dim Ask_For_List As Boolean
0043Dim strMessage As String
0044Dim Total_Run As Single
0045Dim Run_Type As String
0046Dim All_Done As Boolean
0047Dim RunDate As Date
0048Dim Response As String
0049Dim Duration As Single
0050Dim strAuthors As String
0051Dim Set_Colour_Link As String
0052Dim strWriteUp_Note As String
0053Dim iCount As Long
0054Dim Pseudo_Book As Boolean
0055Dim Link_Count As Integer
0056Dim Link_1 As String
0057Dim Link_2 As String
0058Dim Link_3 As String
0059Dim Link_4 As String
0060Dim Link_5 As String
0061Dim Link_6 As String
0062Dim Link_Authors As String
0063Dim strTable As String
0064Dim BlankSpace As String
0065Dim strQuery As String
0066Dim strNote_Date As String
0067Dim SubDirectory As String
0068Dim sw As StopWatch
0069Dim sw2 As StopWatch
0070Test_Flag = False
0071'Test_Flag = True
0072If Test_Flag = True Then
0073 Set sw = New StopWatch
0074 Set sw2 = New StopWatch
0075End If
0076iCount = 0
0077Set fsoTextFile = New FileSystemObject
0078strFolder = strOutputFolder
0079Cross_Reference_Table_Open = False
0080Set rsCross_Reference_Table = Nothing
0081StartTime = Now()
0082Regen_Books_Only = "No"
0083Ask_For_List = False
0084Run_Type = "Not_Ranges"
0085If automatic_processing = "Full" Then
0086 strDataQuery = strDataQuery & "_Range"
0087 Run_Type = "Ranges"
0088 GoTo Automatic
0089End If
0090If automatic_processing = "No" Then
0091 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Books_To_Regen.Book_ID, IIf([Author & Title] & """"="""",""Invalid Book ID"",[Author & Title]) AS [Book Title] FROM Books_To_Regen LEFT JOIN Books ON Books_To_Regen.Book_ID = Books.ID1 ORDER BY Books_To_Regen.Book_ID;")
0092 First_Book_To_Regen = 0
0093 i = 0
0094 If Not rsTableControl.EOF Then
0095 rsTableControl.MoveFirst
0096 First_Book_To_Regen = rsTableControl.Fields(0) & " (" & Left(rsTableControl.Fields(1), 50) & " ..."
0097 i = rsTableControl.RecordCount
0098 End If
0099 If i = 0 Then
0100 Regen_Blurb = ""
0101 Else
0102 If i = 1 Then
0103 Regen_Blurb = "Do you want to select the same Books as last time? The Book is " & First_Book_To_Regen & ")."
0104 Else
0105 If i > 9 Then
0106 Regen_Blurb = "The first 10 Books (of " & i & ") are:-" & Chr$(10)
0107 Else
0108 Regen_Blurb = "The " & i & " Books are:-" & Chr$(10)
0109 End If
0110 For j = 1 To 10
0111 If rsTableControl.EOF Then
0112 j = 11
0113 Else
0114 First_Book_To_Regen = rsTableControl.Fields(0) & " (" & Left(rsTableControl.Fields(1), 50) & " ..."
0115 Regen_Blurb = Regen_Blurb & IIf(j = 1, "", ",") & Chr$(10) & "..." & rsTableControl.Fields(0) & " (" & Left(rsTableControl.Fields(1), 50) & " ... )"
0116 rsTableControl.MoveNext
0117 End If
0118 Next j
0119 Regen_Blurb = "Do you want to select the same Book(s) as last time? " & Regen_Blurb
0120 End If
0121 End If
0122 If MsgBox("Do you want to select individual Books?", vbYesNo) = vbYes Then
0123 Regen_Books_Only = "Yes"
0124 If Regen_Blurb <> "" Then
0125 If MsgBox(Regen_Blurb, vbYesNo) <> vbYes Then
0126 Ask_For_List = True
0127 End If
0128 Else
0129 Ask_For_List = True
0130 End If
0131 End If
0132 If Ask_For_List = True Then
0133 DoCmd.RunSQL ("DELETE Books_To_Regen.* FROM Books_To_Regen;")
0134 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Books_To_Regen.* FROM Books_To_Regen;")
0135 Temp_Book_ID = 1
0136 Do While Temp_Book_ID <> 0
0137 Temp_Book_ID = 0
0138 Temp_Book_ID = Val(InputBox("Enter a Book ID"))
0139 If Temp_Book_ID <> 0 Then
0140 rsTableControl.AddNew
0141 rsTableControl.Fields(0) = Temp_Book_ID
0142 On Error Resume Next
0143 rsTableControl.Update
0144 If Err.Number = 3022 Then
0145 MsgBox ("Duplicate Book (" & Temp_Book_ID & ") selected")
0146 End If
0147 Err.Number = 0
0148 End If
0149 Loop
0150 'Check we've got it right!
0151 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Books_To_Regen.Book_ID, IIf([Author & Title] & """"="""",""Invalid Book ID"",[Author & Title]) AS [Book Title] FROM Books_To_Regen LEFT JOIN Books ON Books_To_Regen.Book_ID = Books.ID1 ORDER BY Books_To_Regen.Book_ID;")
0152 First_Book_To_Regen = 0
0153 i = 0
0154 If Not rsTableControl.EOF Then
0155 rsTableControl.MoveFirst
0156 First_Book_To_Regen = rsTableControl.Fields(0) & " (" & Left(rsTableControl.Fields(1), 50) & " ..."
0157 i = rsTableControl.RecordCount
0158 End If
0159 If i = 0 Then
0160 Regen_Blurb = ""
0161 Else
0162 If i = 1 Then
0163 Regen_Blurb = "Do you want to select this Book? The Book is " & First_Book_To_Regen & " ... )."
0164 Else
0165 If i > 9 Then
0166 Regen_Blurb = "The first 10 Books (of " & i & ") are:-" & Chr$(10)
0167 Else
0168 Regen_Blurb = "The " & i & " Books are:-" & Chr$(10)
0169 End If
0170 For j = 1 To 10
0171 If rsTableControl.EOF Then
0172 j = 11
0173 Else
0174 First_Book_To_Regen = rsTableControl.Fields(0) & " (" & Left(rsTableControl.Fields(1), 50) & " ..."
0175 Regen_Blurb = Regen_Blurb & IIf(j = 1, "", ",") & Chr$(10) & "..." & rsTableControl.Fields(0) & " (" & Left(rsTableControl.Fields(1), 50) & " ... )"
0176 rsTableControl.MoveNext
0177 End If
0178 Next j
0179 Regen_Blurb = "Do you want to select these Books? " & Regen_Blurb
0180 End If
0181 If i > 0 Then
0182 If MsgBox(Regen_Blurb, vbYesNo) <> vbYes Then
0183 MsgBox ("Try again then!")
0184 Exit Sub
0185 End If
0186 End If
0187 End If
0188 End If
0189 If Regen_Books_Only = "Yes" Then
0190 strControlQuery = "SELECT Books_To_Regen.* FROM Books_To_Regen;"
0191 Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0192 If Not rsTableToRead.EOF Then
0193 Regen_Books_Only = "Yes"
0194 strDataQuery = strDataQuery & "_Regen"
0195 If automatic_processing = "No" Then
0196 strDataQuery = strDataQuery & "_Old"
0197 End If
0198 Else
0199 If MsgBox("Would you like to re-create only books with changed Books to Papers Links? If so, respond ""Yes"". ", vbYesNo) = vbYes Then
0200 strDataQuery = strDataQuery & "_Changed"
0201 End If
0202 End If
0203 Else
0204 If MsgBox("Would you like to re-create only books with changed Books to Papers Links? If so, respond ""Yes"". ", vbYesNo) = vbYes Then
0205 strDataQuery = strDataQuery & "_Changed"
0206 Else
0207 'New Code ... check for ranges
0208 If MsgBox("Would you like to re-create book-paper abstracts within ID ranges? If so, respond ""Yes"". ", vbYesNo) = vbYes Then
0209 strDataQuery = strDataQuery & "_Range"
0210 'Set the range(s)
0211 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM BookPaperAbstract_Ranges WHERE [Select?] = True ORDER BY ID_Start;")
0212 If Not rsTableToRead.EOF Then
0213 rsTableToRead.MoveFirst
0214 strMessage = "Run for the following range" & IIf(rsTableToRead.RecordCount > 1, "s", "") & "?" & Chr(10) & Chr(10)
0215 Do While Not rsTableToRead.EOF
0216 strMessage = strMessage & rsTableToRead.Fields(0) & ": " & rsTableToRead.Fields(1) & "-" & rsTableToRead.Fields(2) & ": " & Round(rsTableToRead.Fields(5), 0) & " mins (" & Round(rsTableToRead.Fields(4), 0) & ", " & Round((Now() - Round(rsTableToRead.Fields(4))), 0) & " days)" & Chr(10)
0217 Total_Run = Total_Run + rsTableToRead.Fields(5)
0218 rsTableToRead.MoveNext
0219 Loop
0220 strMessage = strMessage & "Total time = " & Round(Total_Run, 0) & " mins." & Chr(10) & Chr(10)
0221 Else
0222 DoCmd.OpenTable ("BookPaperAbstract_Ranges")
0223 MsgBox ("No Ranges selected. Update the BookPaperAbstract_Ranges Table.")
0224 End
0225 End If
0226 Total_Run = 0
0227 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM BookPaperAbstract_Ranges WHERE [Select?] = False ORDER BY ID_Start;")
0228 If Not rsTableToRead.EOF Then
0229 strMessage = strMessage & "Not selected:- " & Chr(10) & Chr(10)
0230 rsTableToRead.MoveFirst
0231 Do While Not rsTableToRead.EOF
0232 strMessage = strMessage & rsTableToRead.Fields(0) & ": " & rsTableToRead.Fields(1) & "-" & rsTableToRead.Fields(2) & ": " & Round(rsTableToRead.Fields(5), 0) & " mins (" & Round(rsTableToRead.Fields(4), 0) & ", " & Round((Now() - Round(rsTableToRead.Fields(4))), 0) & " days)" & Chr(10)
0233 Total_Run = Total_Run + rsTableToRead.Fields(5)
0234 rsTableToRead.MoveNext
0235 Loop
0236 strMessage = strMessage & "Total time outstanding = " & Round(Total_Run, 0) & " mins." & Chr(10) & Chr(10)
0237 End If
0238 Response = MsgBox(strMessage, vbYesNo)
0239 If Response = vbNo Then
0240 DoCmd.OpenTable ("BookPaperAbstract_Ranges")
0241 MsgBox ("Update the BookPaperAbstract_Ranges Table.")
0242 End
0243 End If
0244 'Need to set a variable for later processing in loop
0245 Run_Type = "Ranges"
0246 Else
0247 If MsgBox("Would you like to re-create All Book-Paper Abstracts - this will take many hours? If so, respond ""Yes"". ", vbYesNo) <> vbYes Then
0248 MsgBox ("Try again")
0249 Exit Sub
0250 End If
0251 End If
0252 End If
0253 End If
0254Else
0255 strDataQuery = strDataQuery & "_Changed"
0256End If
0257Automatic:
0258All_Done = False
0259StartTime = Now()
0260RunStartTime = Now()
0261BookID = 0 'There is no Book 0
0262strFileSuffix = ""
0263strFileBody = ""
0264Pseudo_Book = False
0265 OK = Convert_Webrefs("Book", "Full")
0266If Run_Type = "Ranges" Then
0267 Set rsTableToRead3 = CurrentDb.OpenRecordset("SELECT * FROM BookPaperAbstract_Ranges WHERE [Select?] = True ORDER BY ID_Start;")
0268 If rsTableToRead3.EOF Then
0269 All_Done = True
0270 Else
0271 rsTableToRead3.MoveFirst
0272 End If
0273End If
0274Do Until All_Done = True
0275 If Run_Type <> "Ranges" Then
0276 All_Done = True
0277 Else
0278 'Generate records list
0279 strControlQuery = "Select Current_ID.* FROM Current_ID; "
0280 Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery) 'Borrow this recordset!
0281 rsTableToRead.MoveFirst
0282 rsTableToRead.Edit
0283 rsTableToRead.Fields(0) = rsTableToRead3.Fields(0)
0284 rsTableToRead.Update
0285 End If
0286 'Read the data
0287 Set rsTableToRead = CurrentDb.OpenRecordset(strDataQuery)
0288 'Column 0 is the Book ID, Column 1 is the Paper ID
0289 iDepth = 3
0290 If Not rsTableToRead.EOF Then
0291 rsTableToRead.MoveFirst
0292 iTableColumns = rsTableToRead.Fields.Count
0293 Do Until rsTableToRead.EOF
0294 BookID = rsTableToRead.Fields(0)
0295 PaperID = rsTableToRead.Fields(1)
0296 If BookID_Previous <> BookID Then 'New Book
0297 'Write the previous Footer (except first time)
0298 If BookID_Previous <> 0 Then
0299 If Pseudo_Book = True Then
0300 strLine = "<hr><p>The papers in this ""Pseudo-book"" are too many to show their Abstracts in a concatenated list, nor is this useful. For the list of papers (from which the Abstracts can be found) follow <A HREF = ""../BooksToPapers_" & BookID_Previous & ".htm"">this link</A>. If this is a multi-volume pseudo-book, for the other volumes follow the links from the pseudo-author ""Various"" in the heading at the top of the page."
0301 Else
0302 strLine = ""
0303 End If
0304 strLine = strLine & "<a name=""ColourConventions""></a><hr><br><B><U>Text Colour Conventions</U> (see <A HREF=""../../../Notes/Notes_10/Notes_1025.htm"">disclaimer</a>)</B><OL TYPE=""1"">"
0305 For i = 0 To 19
0306 If Colour_Table(i, 4) = "1" Then
0307 strLine = strLine & "<LI><FONT COLOR = """ & Colour_Table(i, 1) & """>" & Colour_Table(i, 2) & "</FONT>: " & Colour_Table(i, 3) & "</li>"
0308 End If
0309 Next i
0310 strLine = strLine & "</OL>"
0311 OK = TrimBranches(strLine)
0312 tsTextFile.WriteLine strLine
0313 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;"
0314 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0315 rsTableControl.MoveFirst
0316 Do While Not rsTableControl.EOF
0317 strLine = rsTableControl.Fields(0) & ""
0318 OK = Replace_Timestamp(strLine)
0319 OK = TrimBranches(strLine)
0320 tsTextFile.WriteLine strLine
0321 rsTableControl.MoveNext
0322 Loop
0323 If Test_Flag = True Then
0324 sw2.StartTimer
0325 End If
0326 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0327 If Test_Flag = True Then
0328 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " CopyToTransfer"
0329 Debug.Print Now(); strFileSuffix; sw.EndTimer; "Milliseconds"
0330 Stop
0331 sw.StartTimer
0332 End If
0333 iCount = iCount + 1
0334 Else
0335 If Test_Flag = True Then
0336 sw.StartTimer
0337 End If
0338 End If
0339 Print_The_First_Paper = "Yes"
0340 'Ignore "dummy" papers with no Comment or Abstract
0341 If rsTableToRead.Fields(11) & "" = "" And rsTableToRead.Fields(12) & "" = "" Then
0342 If rsTableToRead.Fields(2) = rsTableToRead.Fields(4) Then 'Author of book = author of paper
0343 If rsTableToRead.Fields(3) = rsTableToRead.Fields(5) Then 'Title of book = title of paper
0344 Print_The_First_Paper = "No"
0345 End If
0346 End If
0347 End If
0348 'Ignore the papers in pseudo-books
0349 If rsTableToRead.Fields(17) = "Yes" Then
0350 Print_The_First_Paper = "No"
0351 Pseudo_Book = True
0352 Else
0353 Pseudo_Book = False
0354 End If
0355 BookID_Previous = BookID
0356 Clear_Colour_Usage
0357 strFileSuffix_Previous = strFileSuffix
0358 strFileBody_Previous = strFileBody
0359 strFileSuffix = strOutputFileShort & "_" & BookID
0360 strFileBody = "BookSummary_" & Right((Int((BookID / 1000) + 1000000)), 2) & "\BookPaperAbstracts"
0361 'Create File
0362 Set tsTextFile = fsoTextFile.CreateTextFile(strOutputFolder & strFileBody & "\" & strFileSuffix & ".htm", True, True)
0363 Link_Count = 0
0364 Link_1 = ""
0365 Link_2 = ""
0366 Link_3 = ""
0367 Link_4 = ""
0368 Link_5 = ""
0369 Link_6 = ""
0370 Link_Authors = ""
0371 'Page Header
0372 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;"
0373 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0374 rsTableControl.MoveFirst
0375 Do While Not rsTableControl.EOF
0376 strLine = rsTableControl.Fields(0) & ""
0377 x = InStr(1, strLine, "**BOOK**")
0378 If x > 0 Then
0379 If Test_Flag = True Then
0380 sw2.StartTimer
0381 End If
0382 strLine = ""
0383 'Determine whether to output the link to page-end for the colour-conventions
0384 qryString = rsTableToRead.Name
0385 Set_Colour_Link = "No"
0386 If rsTableToRead.Fields(iTableColumns - 2) > 500 Then
0387 Set_Colour_Link = "Yes"
0388 Else
0389 strQuery = "SELECT " & qryString & ".[Book ID], Count(" & qryString & ".[Paper ID]) AS [CountOfPaper ID], " & qryString & ".Book_BlurbLen, Sum(" & qryString & ".Paper_BlurbLen) AS SumOfPaper_BlurbLen FROM " & qryString & " WHERE (((" & qryString & ".[Book ID])=" & BookID & ")) GROUP BY " & qryString & ".[Book ID], " & qryString & ".Book_BlurbLen;"
0390 Set rsColourCheck = CurrentDb.OpenRecordset(strQuery)
0391 rsColourCheck.MoveFirst
0392 If rsColourCheck.Fields(1) > 2 Or (rsColourCheck.Fields(2) + rsColourCheck.Fields(3)) > 500 Then
0393 Set_Colour_Link = "Yes"
0394 End If
0395 Set rsColourCheck = Nothing
0396 End If
0397 If Test_Flag = True Then
0398 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " Book"
0399 End If
0400 strAuthors = rsTableToRead.Fields(2)
0401 OK = Author_Reference_String(strAuthors, 3)
0402 'Add the Book author & title + Link to Colour Conventions (if required ...)
0403 Link_1 = "<A HREF = """ & "../BookSummary_" & BookID & ".htm" & """>" & rsTableToRead.Fields(3) & "</A>"
0404 Link_2 = strAuthors
0405 If Set_Colour_Link = "Yes" Then
0406 Link_3 = "<A HREF=""#ColourConventions"">Colour-Conventions</a>"
0407 Link_Count = Link_Count + 1
0408 End If
0409 End If
0410 x = InStr(1, strLine, "**TITLE**")
0411 If x > 0 Then
0412 'Add the Book author & title
0413 strLine = Left(strLine, x - 1) & "" & rsTableToRead.Fields(3) & " (" & rsTableToRead.Fields(2) & ") - Theo Todman's Book Collection (Book-Paper Abstracts)" & Mid(strLine, x + 9, Len(strLine))
0414 End If
0415 OK = TrimBranches(strLine)
0416 tsTextFile.WriteLine strLine
0417 rsTableControl.MoveNext
0418 Loop
0419 'Output Book, Paper & Notes citing links
0420 If Test_Flag = True Then
0421 sw2.StartTimer
0422 End If
0423 strControlQuery = "SELECT Book_Citings_List_New.* FROM Book_Citings_List_New WHERE Book_Citings_List_New.Book_ID = " & rsTableToRead.Fields(0) & ";"
0424 Set rsCitings = CurrentDb.OpenRecordset(strControlQuery)
0425 If Not rsCitings.EOF Then
0426 rsCitings.MoveFirst
0427 Link_4 = "<A HREF = ""../BookCitings_" & rsTableToRead.Fields(0) & ".htm"">Books / Papers Citing this Book</A>"
0428 Link_Count = Link_Count + 1
0429 Set rsCitings = Nothing
0430 End If
0431 If Test_Flag = True Then
0432 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " Book_Citings"
0433 End If
0434 If Test_Flag = True Then
0435 sw2.StartTimer
0436 End If
0437 strControlQuery = "SELECT Book_Note_Counts.* FROM Book_Note_Counts WHERE Book_Note_Counts.Book = " & rsTableToRead.Fields(0) & ";"
0438 Set rsCitings = CurrentDb.OpenRecordset(strControlQuery)
0439 If Not rsCitings.EOF Then
0440 rsCitings.MoveFirst
0441 Link_5 = "<A HREF = ""../BooksToNotes_" & rsTableToRead.Fields(0) & ".htm"">Notes Citing this Book</A>"
0442 Link_Count = Link_Count + 1
0443 Set rsCitings = Nothing
0444 End If
0445 If Test_Flag = True Then
0446 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " Book_Note_Counts"
0447 End If
0448 If Link_3 <> "" Or InStr(rsTableToRead.Fields(9) & "", "|Colour_2|") > 0 Or InStr(rsTableToRead.Fields(10) & "", "|Colour_2|") > 0 Then
0449 Link_6 = "<A HREF=""../../../Notes/Notes_10/Notes_1025.htm"">Disclaimer</a>"
0450 Link_Count = Link_Count + 1
0451 End If
0452 strTable = "<hr><CENTER><TABLE class = ""Bridge"" WIDTH=950>"
0453 If Link_1 <> "" Then
0454 strTable = strTable & "<tr><td colspan =" & IIf(Link_Count > 0, Link_Count, 1) & ">" & Link_1 & "</td></tr>"
0455 End If
0456 If Link_2 <> "" Then
0457 strTable = strTable & "<tr><td colspan =" & IIf(Link_Count > 0, Link_Count, 1) & ">" & Link_2 & "</td></tr>"
0458 End If
0459 strTable = strTable & "<tr><td colspan =" & IIf(Link_Count > 0, Link_Count, 1) & ">" & "This Page provides (where held) the <b>Abstract</b> of the above <b>Book</b> and those of all the <b>Papers</b> contained in it." & "</td></tr>"
0460 If Link_Count > 0 Then
0461 strTable = strTable & "<tr>"
0462 If Link_3 <> "" Then
0463 strTable = strTable & "<td>" & Link_3 & "</td>"
0464 End If
0465 If Link_6 <> "" Then
0466 strTable = strTable & "<td>" & Link_6 & "</td>"
0467 End If
0468 If Link_4 <> "" Then
0469 strTable = strTable & "<td>" & Link_4 & "</td>"
0470 End If
0471 If Link_5 <> "" Then
0472 strTable = strTable & "<td>" & Link_5 & "</td>"
0473 End If
0474 strTable = strTable & "</tr>"
0475 End If
0476 strTable = strTable & "</tr></TABLE></CENTER><hr>"
0477 tsTextFile.WriteLine strTable
0478 'Add Author Citings
0479 If Test_Flag = True Then
0480 sw2.StartTimer
0481 End If
0482 strControlQuery = "SELECT Authors.Author_Name FROM Authors INNER JOIN Cross_Reference ON Authors.Author_ID = Cross_Reference.Calling_ID WHERE (((Cross_Reference.Called_ID) = " & rsTableToRead.Fields(0) & ") And ((Cross_Reference.Calling_Type) = ""A"") And ((Cross_Reference.Called_Type) = ""B"")) ORDER BY Authors.Author_Name;"
0483 Set rsCitings = CurrentDb.OpenRecordset(strControlQuery)
0484 If Not rsCitings.EOF Then
0485 rsCitings.MoveFirst
0486 strLine = "<B>Authors Citing this Book</B>: "
0487 strLine = strLine & "<A HREF = ""../../../Authors/" & Left(rsCitings.Fields(0), 1) & "/Author_" & rsCitings.Fields(0) & ".htm"">" & rsCitings.Fields(0) & "</A>"
0488 rsCitings.MoveNext
0489 Do While Not rsCitings.EOF
0490 strLine = strLine & ", <A HREF = ""../../../Authors/" & Left(rsCitings.Fields(0), 1) & "/Author_" & rsCitings.Fields(0) & ".htm"">" & rsCitings.Fields(0) & "</A>"
0491 rsCitings.MoveNext
0492 Loop
0493 strLine = "<p>" & strLine & "</p><hr>"
0494 tsTextFile.WriteLine strLine
0495 Set rsCitings = Nothing
0496 End If
0497 If Test_Flag = True Then
0498 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " Author Citings"
0499 End If
0500 'Book Abstract
0501 OK = Zap_Cross_References("B", BookID, 0)
0502 NameRef = 0
0503 strText = ""
0504 strAbstract = Trim(rsTableToRead.Fields(9) & "")
0505 If Len(strAbstract) > 0 Then
0506 OK = Reference_FootNotes("B", BookID, strAbstract, "+B" & BookID & "B+")
0507 strText = "|Colour_1|<B>BOOK ABSTRACT: </B>" & IIf(Left(strAbstract, 1) = "|", "", "<BR><BR>") & strAbstract
0508 Else
0509 strText = "|Colour_1|<B>BOOK ABSTRACT: </B>None."
0510 End If
0511 'Write out Comment
0512 strComment = Trim(rsTableToRead.Fields(10) & "")
0513 If Len(strComment) > 0 Then
0514 strText = strText & "|Colour_1|<HR><B>BOOK COMMENT: </B>" & IIf(Left(strComment, 1) = "|", "", "<BR><BR>") & strComment
0515 End If
0516 'Format & Write out
0517 strLine = "<P ALIGN = ""Justify""><FONT Size = 2 FACE=""Arial"">" & strText & "</P>"
0518 strLine = Remove_Dummy_Ref(strLine)
0519 strLine = WebEncode(strLine)
0520 OK = Reference_Notes(strLine, "B", BookID, 0, iDepth) 'Replace the Notes References by hyperlinks
0521 OK = Reference_Notes(strLine, "B", BookID, 0, iDepth, "Abstract_Direct") 'Replace the Notes References by hyperlinks
0522 OK = Reference_Papers(strLine, "B", BookID, 0, iDepth) 'Replace the Papers References by hyperlinks
0523 OK = Reference_Author(strLine, "B", BookID, 0, iDepth) 'Replace the Author References by hyperlinks
0524 OK = Reference_Note_Links(strLine, "B", BookID, 0) 'Replace the Note Link References by hyperlinks
0525 OK = Reference_Books(strLine, "B", BookID, 0, iDepth) 'Replace the Books References by hyperlinks
0526 'Encode any unencoded references first - otherwise they never get encoded!
0527 OK = Reference_Webrefs(strLine, "B", BookID, 0)
0528 strLine = ReplaceCode(strLine, Chr(13) & Chr(10), "<BR>")
0529 strLine = NumberedBullets(strLine)
0530 strLine = Bullets(strLine)
0531 OK = Mark_Colours(strLine)
0532 OK = TrimBranches(strLine)
0533 tsTextFile.WriteLine strLine
0534 If Test_Flag = True Then
0535 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " Book Abstract"
0536 End If
0537 'Log Referencing Changes
0538 If Full_Regen = False Then
0539 DoCmd.OpenQuery ("Cross_Reference_Changes_Deletions_Add")
0540 DoCmd.OpenQuery ("Cross_Reference_Changes_Additions_Add")
0541 If Test_Flag = True Then
0542 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " Cross_Reference_Changes"
0543 End If
0544 End If
0545 End If
0546 'Paper Abstracts
0547 If Print_The_First_Paper = "Yes" Then
0548 'Determine Paper Title
0549 PaperTitle = ""
0550 PaperRef = rsTableToRead.Fields(1)
0551 qryString = "SELECT Papers.Author, Papers.Title, Papers.Abstract_Quality FROM Papers WHERE (((Papers.ID)=" & PaperRef & "));"
0552 Set rsTableToRead2 = CurrentDb.OpenRecordset(qryString)
0553 If Not rsTableToRead2.EOF Then
0554 rsTableToRead2.MoveFirst
0555 PaperTitle = rsTableToRead2.Fields(0).Value & " - " & rsTableToRead2.Fields(1).Value
0556 z = Str(Int(PaperRef / 1000) + 1000000)
0557 strText = "|Colour_1|<HR><BR>""<B><A HREF = """ & "../../PaperSummaries/PaperSummary_" & Right(z, 2) & "/PaperSummary_" & PaperRef & ".htm"">" & PaperTitle & "</A></B>""<BR>"
0558 Else
0559 PaperTitle = """Unknown Paper"""
0560 strText = "|Colour_1|<HR><BR><B>" & PaperTitle & "</B><BR>"
0561 End If
0562 Set rsTableToRead2 = Nothing
0563 If rsTableToRead.Fields(6) & "" <> "" Then
0564 strText = strText & "<BR><B>" & "Source</B>: " & rsTableToRead.Fields(6) & "<BR>"
0565 Else
0566 strText = strText & "<BR>"
0567 End If
0568 If rsTableToRead.Fields(16) & "" = "" Then
0569 strWriteUp_Note = ""
0570 Else
0571 strWriteUp_Note = "Write-up Note++" & rsTableToRead.Fields(16) & "++ (Full Text reproduced below). "
0572 End If
0573 strAbstract = Trim(rsTableToRead.Fields(11) & "")
0574 strComment = Trim(rsTableToRead.Fields(12) & "")
0575 If Len(strComment) > 5000 Then
0576 strAbstract = strAbstract & strComment
0577 strComment = ""
0578 End If
0579 If strAbstract <> "" Then
0580 If Len(strAbstract) > 0 Then
0581 BlankSpace = Left(strAbstract, 4)
0582 If BlankSpace = "|..|" Or BlankSpace = "|99|" Or BlankSpace = "|ii|" Or BlankSpace = "|II|" Or BlankSpace = "|aa|" Or BlankSpace = "|AA|" Or BlankSpace = "|##|" Then
0583 BlankSpace = ""
0584 Else
0585 BlankSpace = "<BR><BR>"
0586 End If
0587 strText = strText & "|Colour_1|" & strWriteUp_Note & BlankSpace & strAbstract
0588 Else
0589 If strWriteUp_Note <> "" Then
0590 strText = strText & "|Colour_1|" & strWriteUp_Note & "<BR><BR>"
0591 End If
0592 End If
0593 Else
0594 If strWriteUp_Note <> "" Then
0595 strText = strText & "|Colour_1|" & strWriteUp_Note & "<BR><BR>"
0596 End If
0597 End If
0598 If rsTableToRead.Fields(12) & "" <> "" Then
0599 If Len(strComment) > 0 And Len(strComment) <= 5000 Then
0600 If Len(Trim(strAbstract)) > 0 Then
0601 strText = strText & "<BR><BR>"
0602 End If
0603 strText = strText & "|Colour_1|<B>COMMENT: </B>" & strComment
0604 End If
0605 End If
0606 'Add the Write-up Note (if any)
0607 If strWriteUp_Note <> "" Then
0608 strQuery = "SELECT Notes.ID, Notes.Item_Title, Notes.Item_Text, Notes.Last_Changed, Notes.[Private?] FROM Notes WHERE (((Notes.ID)=" & rsTableToRead.Fields(16) & "));"
0609 Set rsNote = CurrentDb.OpenRecordset(strQuery)
0610 If Not rsNote.EOF Then
0611 If rsNote.Fields(4) & "" = "No" Then
0612 strNote_Date = rsNote.Fields(3) & ""
0613 If strNote_Date <> "" Then
0614 strNote_Date = CDate(strNote_Date / 1000)
0615 Else
0616 strNote_Date = Now()
0617 End If
0618 strQuery = "SELECT Note_Groups.Note_Group FROM Notes INNER JOIN Note_Groups ON Notes.Note_Group = Note_Groups.ID WHERE (((Notes.ID)=" & rsTableToRead.Fields(16) & "));"
0619 Set rsNote2 = CurrentDb.OpenRecordset(strQuery)
0620 SubDirectory = Find_New_Directory(rsTableToRead.Fields(16))
0621 SubDirectory = SubDirectory & "/Notes_"
0622 If rsNote2.Fields(0) = "Supervisions" Then
0623 SubDirectory = "../../Secure_Jen/Notes_" & SubDirectory
0624 Else
0625 SubDirectory = "../../Notes/Notes_" & SubDirectory
0626 End If
0627 Link_4 = "<A HREF = """ & SubDirectory & rsTableToRead.Fields(16).Value & ".htm"">Link to Latest Write-Up Note</A>"
0628 strText = strText & "|Colour_1|<hr><br><B><u>Write-up++FN|..||.|This is the write-up as it was when this Abstract was last output, with text as at the timestamp indicated (" & strNote_Date & "). |.|" & Link_4 & ". |..|++</u> (as at " & strNote_Date & "): " & rsNote.Fields(1) & "</B><BR><br>" & ImageRef(rsNote.Fields(2), "Abstract", "P", rsTableToRead.Fields(0), 0)
0629 End If
0630 End If
0631 Set rsNote = Nothing
0632 Set rsNote2 = Nothing
0633 End If
0634 'Format & Write out
0635 strText = Remove_Dummy_Ref(strText)
0636 strText = WebEncode(strText)
0637 strLine = "<P ALIGN = ""Justify""><FONT Size = 2 FACE=""Arial"">" & strText & "</P>"
0638 strLine = ReplaceCode(strLine, """../", """../../") '... because we're down a directory-level
0639 OK = Reference_FootNotes("P", rsTableToRead.Fields(1), strLine, "+P" & rsTableToRead.Fields(1) & "P+")
0640 OK = Reference_Notes(strLine, "X", 0, 0, iDepth, "Abstract_Direct") 'Replace the Notes References by hyperlinks
0641 OK = Reference_Notes(strLine, "X", 0, 0, iDepth) 'Replace the Notes References by hyperlinks
0642 OK = Reference_Author(strLine, "X", 0, 0, iDepth) 'Replace the Author References by hyperlinks
0643 OK = Reference_Note_Links(strLine, "B", 0, 0) 'Replace the Note Link References by hyperlinks
0644 OK = Reference_Papers(strLine, "X", 0, 0, iDepth) 'Replace the Papers References by hyperlinks
0645 OK = Reference_Books(strLine, "X", 0, 0, iDepth) 'Replace the Books References by hyperlinks
0646 OK = Reference_Reference(strLine) 'Replace the References References by Names
0647 OK = Reference_Webrefs(strLine, "X", 0, 0)
0648 strLine = ReplaceCode(strLine, Chr(13) & Chr(10), "<BR>")
0649 strLine = NumberedBullets(strLine)
0650 strLine = Bullets(strLine)
0651 OK = Mark_Colours(strLine)
0652 OK = TrimBranches(strLine)
0653 tsTextFile.WriteLine strLine
0654 Else
0655 If rsTableToRead.Fields(17) = "No" Then
0656 Print_The_First_Paper = "Yes" 'Flag further papers as printable
0657 End If
0658 End If
0659 'Next Record
0660 rsTableToRead.MoveNext
0661 Loop
0662 'Write the Last Footer
0663 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;"
0664 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0665 If Pseudo_Book = True Then
0666 strLine = "<hr><p>The papers in this ""Pseudo-book"" are too many to show their Abstracts in a concatenated list, nor is this useful. For the list of papers (from which the Abstracts can be found) follow <A HREF = ""../BooksToPapers_" & BookID & ".htm"">this link</A>. If this is a multi-volume pseudo-book, for the other volumes follow the links from the pseudo-author ""Various"" in the heading at the top of the page."
0667 Else
0668 strLine = ""
0669 End If
0670 strLine = strLine & "<a name=""ColourConventions""></a><br><hr><br><B><U>Text Colour Conventions</U> (see <A HREF=""../../../Notes/Notes_10/Notes_1025.htm"">disclaimer</a>)</B><OL TYPE=""1"">"
0671 For i = 0 To 19
0672 If Colour_Table(i, 4) = "1" Then
0673 strLine = strLine & "<LI><FONT COLOR = """ & Colour_Table(i, 1) & """>" & Colour_Table(i, 2) & "</FONT>: " & Colour_Table(i, 3) & "</li>"
0674 End If
0675 Next i
0676 strLine = strLine & "</OL>"
0677 OK = TrimBranches(strLine)
0678 tsTextFile.WriteLine strLine
0679 rsTableControl.MoveFirst
0680 Do While Not rsTableControl.EOF
0681 strLine = rsTableControl.Fields(0) & ""
0682 OK = Replace_Timestamp(strLine)
0683 OK = TrimBranches(strLine)
0684 tsTextFile.WriteLine strLine
0685 rsTableControl.MoveNext
0686 Loop
0687 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0688 iCount = iCount + 1
0689 End If
0690 If Run_Type = "Ranges" Then
0691 'Update the BookPaperAbstract_Ranges Table
0692 Duration = Now() - StartTime
0693 Duration = Duration * 24 * 60
0694 Duration = Round(Duration, 1)
0695 RunDate = Now()
0696 rsTableToRead3.Edit
0697 rsTableToRead3.Fields(4) = RunDate
0698 rsTableToRead3.Fields(5) = Duration
0699 rsTableToRead3.Update
0700 'Read Next Range
0701 rsTableToRead3.MoveNext
0702 If rsTableToRead3.EOF Then
0703 All_Done = True
0704 End If
0705 StartTime = Now()
0706 End If
0707Loop
0708Set fsoTextFile = Nothing
0709Set tsTextFile = Nothing
0710Set rsTableToRead = Nothing
0711Set rsTableToRead2 = Nothing
0712Set rsTableToRead3 = Nothing
0713Set rsTableControl = Nothing
0714Cross_Reference_Table_Open = False
0715Set rsCross_Reference_Table = Nothing
0716 DoCmd.OpenQuery ("Cross_Reference_Idempotency_Zap")
0717If Test_Flag = True Then
0718 Set sw = Nothing
0719 Set sw2 = Nothing
0720End If
0721Duration = Round((Now() - RunStartTime) * 24 * 60, 1)
0722If automatic_processing <> "Full" And automatic_processing <> "Yes" Then
0723 If Duration < 1 Then
0724 Duration = Round((Now() - RunStartTime) * 24 * 60 * 60)
0725 MsgBox Now() & ": Printable Book Paper Abstracts Webpage Creation Complete in " & Duration & " seconds. " & iCount & " pages output.", vbOKOnly, "Create Book Paper Abstracts Web Pages"
0726 Else
0727 MsgBox Now() & ": Printable Book Paper Abstracts Webpage Creation Complete in " & Duration & " minutes. " & iCount & " pages output.", vbOKOnly, "Create Book Paper Abstracts Web Pages"
0728 End If
0729End If
0730End Sub

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



Source Code of: CreatePapersToBooksWebPages
Procedure Type: Public Sub
Module: New Code
Lines of Code: 406
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub CreatePapersToBooksWebPages()
0002'This is a new module to generate the pages that list the Papers associated with a particular Book.
0003'It was based on Sub CreatePapersWebTable
0004Dim fsoTextFile As FileSystemObject
0005Dim tsTextFile As TextStream
0006Dim rsTableToRead As Recordset
0007Dim rsTableToRead2 As Recordset
0008Dim rsTableToRead3 As Recordset
0009Dim rsTableControl As Recordset
0010Dim strControlQuery As String
0011Dim strLine As String
0012Dim iTableColumns As Integer
0013Dim iFieldNo As Integer
0014Dim x As Integer
0015Dim i As Integer
0016Dim j As Integer
0017Dim BookID As Integer
0018Dim BookID_Previous As Integer
0019Dim PaperID As Integer
0020Dim strFileSuffix As String
0021Dim strFileSuffix_Previous As String
0022Dim strFileBody As String
0023Dim strFileBody_Previous As String
0024Dim StartTime As Double
0025Dim Temp_Book_ID As Long
0026Dim Regen_Books_Only As String
0027Dim Regen_Blurb As String
0028Dim First_Book_To_Regen As String
0029Dim Ask_For_Refs As Boolean
0030Dim Changed_Only As Boolean
0031Dim Time_Stamp As String
0032Dim strMessage As String
0033Dim Total_Run As Single
0034Dim Run_Type As String
0035Dim All_Done As Boolean
0036Dim RunDate As Date
0037Dim Response As String
0038Dim RunStartTime As Date
0039Dim Duration As Single
0040Dim iCount As Long
0041Dim Print_The_Paper As String
0042Dim First_Paper As Boolean
0043iCount = 0
0044Changed_Only = False
0045Set fsoTextFile = New FileSystemObject
0046strFolder = strOutputFolder
0047StartTime = Now()
0048Regen_Books_Only = "No"
0049Run_Type = "Not_Ranges"
0050If automatic_processing = "Yes" Then
0051 Run_Type = "Ranges"
0052 strDataQuery = strDataQuery & "_Regen"
0053 GoTo Automation
0054End If
0055If MsgBox("Do you want to select individual Books?", vbYesNo) = vbYes Then
0056 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Books_To_Regen.Book_ID, IIf([Author & Title] & """"="""",""Invalid Book ID"",[Author & Title]) AS [Book Title] FROM Books_To_Regen LEFT JOIN Books ON Books_To_Regen.Book_ID = Books.ID1 ORDER BY Books_To_Regen.Book_ID;")
0057 First_Book_To_Regen = ""
0058 i = 0
0059 If Not rsTableControl.EOF Then
0060 rsTableControl.MoveFirst
0061 First_Book_To_Regen = rsTableControl.Fields(0) & " (" & Left(rsTableControl.Fields(1), 50) & " ..."
0062 i = rsTableControl.RecordCount
0063 End If
0064 If i = 0 Then
0065 Regen_Blurb = ""
0066 Else
0067 If i = 1 Then
0068 Regen_Blurb = "Do you want to select the same Books as last time? The Book is " & First_Book_To_Regen & ")."
0069 Else
0070 If i > 9 Then
0071 Regen_Blurb = "The first 10 Books (of " & i & ") are:-" & Chr$(10)
0072 Else
0073 Regen_Blurb = "The " & i & " Books are:-" & Chr$(10)
0074 End If
0075 For j = 1 To 10
0076 If rsTableControl.EOF Then
0077 j = 11
0078 Else
0079 First_Book_To_Regen = rsTableControl.Fields(0) & " (" & Left(rsTableControl.Fields(1), 50) & " ..."
0080 Regen_Blurb = Regen_Blurb & IIf(j = 1, "", ",") & Chr$(10) & "..." & rsTableControl.Fields(0) & " (" & Left(rsTableControl.Fields(1), 50) & " ... )"
0081 rsTableControl.MoveNext
0082 End If
0083 Next j
0084 Regen_Blurb = "Do you want to select the same Books as last time? " & Regen_Blurb
0085 End If
0086 End If
0087 Ask_For_Refs = False
0088 If Regen_Blurb = "" Then
0089 Ask_For_Refs = True
0090 Else
0091 If MsgBox(Regen_Blurb, vbYesNo) <> vbYes Then
0092 Ask_For_Refs = True
0093 End If
0094 End If
0095 If Ask_For_Refs = True Then
0096 DoCmd.RunSQL ("DELETE Books_To_Regen.* FROM Books_To_Regen;")
0097 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Books_To_Regen.* FROM Books_To_Regen;")
0098 Temp_Book_ID = 1
0099 Do While Temp_Book_ID <> 0
0100 Temp_Book_ID = 0
0101 Temp_Book_ID = Val(InputBox("Enter a Book ID"))
0102 If Temp_Book_ID <> 0 Then
0103 rsTableControl.AddNew
0104 rsTableControl.Fields(0) = Temp_Book_ID
0105 On Error Resume Next
0106 rsTableControl.Update
0107 If Err.Number = 3022 Then
0108 MsgBox ("Duplicate Book (" & Temp_Book_ID & ") selected")
0109 End If
0110 Err.Number = 0
0111 End If
0112 Loop
0113 'Check we've got it right!
0114 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Books_To_Regen.Book_ID, IIf([Author & Title] & """"="""",""Invalid Book ID"",[Author & Title]) AS [Book Title] FROM Books_To_Regen LEFT JOIN Books ON Books_To_Regen.Book_ID = Books.ID1 ORDER BY Books_To_Regen.Book_ID;")
0115 First_Book_To_Regen = 0
0116 i = 0
0117 If Not rsTableControl.EOF Then
0118 rsTableControl.MoveFirst
0119 First_Book_To_Regen = rsTableControl.Fields(0) & " (" & Left(rsTableControl.Fields(1), 50) & " ..."
0120 i = rsTableControl.RecordCount
0121 End If
0122 If i = 0 Then
0123 Regen_Blurb = ""
0124 Else
0125 If i = 1 Then
0126 Regen_Blurb = "Do you want to select this Book? The Book is " & First_Book_To_Regen & " ... )."
0127 Else
0128 If i > 9 Then
0129 Regen_Blurb = "The first 10 Books (of " & i & ") are:-" & Chr$(10)
0130 Else
0131 Regen_Blurb = "The " & i & " Books are:-" & Chr$(10)
0132 End If
0133 For j = 1 To 10
0134 If rsTableControl.EOF Then
0135 j = 11
0136 Else
0137 First_Book_To_Regen = rsTableControl.Fields(0) & " (" & Left(rsTableControl.Fields(1), 50) & " ..."
0138 Regen_Blurb = Regen_Blurb & IIf(j = 1, "", ",") & Chr$(10) & "..." & rsTableControl.Fields(0) & " (" & Left(rsTableControl.Fields(1), 50) & " ... )"
0139 rsTableControl.MoveNext
0140 End If
0141 Next j
0142 Regen_Blurb = "Do you want to select these Books? " & Regen_Blurb
0143 End If
0144 End If
0145 If i > 0 Then
0146 If MsgBox(Regen_Blurb, vbYesNo) <> vbYes Then
0147 MsgBox ("Try again then!")
0148 Exit Sub
0149 End If
0150 End If
0151 End If
0152 strControlQuery = "SELECT Books_To_Regen.* FROM Books_To_Regen;"
0153 Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0154 If Not rsTableToRead.EOF Then
0155 Regen_Books_Only = "Yes"
0156 strDataQuery = strDataQuery & "_Regen"
0157 Else
0158 If MsgBox("Would you like to re-create only changed Books to Papers Links? If so, respond ""Yes"". ", vbYesNo) = vbYes Then
0159 Else
0160 Exit Sub
0161 End If
0162 End If
0163Else
0164 If MsgBox("Would you like to re-create changed Books to Papers Links only?" & Chr$(10) & Chr$(10) & "Note that this will additionally automatically regenerate the corresponding changed Book/Paper Abstract pages. " & Chr$(10) & Chr$(10) & "If you want to procede with this option, respond ""Yes"". ", vbYesNo) = vbYes Then
0165 Changed_Only = True
0166 automatic_processing = "Yes"
0167 Else
0168 'New Code ... check for ranges
0169 If MsgBox("Would you like to re-create Books to Papers Links within ID ranges? If so, respond ""Yes"". ", vbYesNo) = vbYes Then
0170 'Set the range(s)
0171 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM BookPaperLinks_Ranges WHERE [Select?] = True ORDER BY ID_Start;")
0172 If Not rsTableToRead.EOF Then
0173 rsTableToRead.MoveFirst
0174 strMessage = "Run for the following range" & IIf(rsTableToRead.RecordCount > 1, "s", "") & "?" & Chr(10) & Chr(10)
0175 Do While Not rsTableToRead.EOF
0176 strMessage = strMessage & rsTableToRead.Fields(0) & ": " & rsTableToRead.Fields(1) & "-" & rsTableToRead.Fields(2) & ": " & Round(rsTableToRead.Fields(5), 0) & " mins (" & Round(rsTableToRead.Fields(4), 0) & ", " & Round((Now() - Round(rsTableToRead.Fields(4))), 0) & " days)" & Chr(10)
0177 Total_Run = Total_Run + rsTableToRead.Fields(5)
0178 rsTableToRead.MoveNext
0179 Loop
0180 strMessage = strMessage & "Total time = " & Round(Total_Run, 0) & " mins." & Chr(10) & Chr(10)
0181 Else
0182 DoCmd.OpenTable ("BookPaperLinks_Ranges")
0183 MsgBox ("No Ranges selected. Update the BookPaperLinks_Ranges Table.")
0184 End
0185 End If
0186 Total_Run = 0
0187 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM BookPaperLinks_Ranges WHERE [Select?] = False ORDER BY ID_Start;")
0188 If Not rsTableToRead.EOF Then
0189 strMessage = strMessage & "Not selected:- " & Chr(10) & Chr(10)
0190 rsTableToRead.MoveFirst
0191 Do While Not rsTableToRead.EOF
0192 strMessage = strMessage & rsTableToRead.Fields(0) & ": " & rsTableToRead.Fields(1) & "-" & rsTableToRead.Fields(2) & ": " & Round(rsTableToRead.Fields(5), 0) & " mins (" & Round(rsTableToRead.Fields(4), 0) & ", " & Round((Now() - Round(rsTableToRead.Fields(4))), 0) & " days)" & Chr(10)
0193 Total_Run = Total_Run + rsTableToRead.Fields(5)
0194 rsTableToRead.MoveNext
0195 Loop
0196 strMessage = strMessage & "Total time outstanding = " & Round(Total_Run, 0) & " mins." & Chr(10) & Chr(10)
0197 End If
0198 Response = MsgBox(strMessage, vbYesNo)
0199 If Response = vbNo Then
0200 DoCmd.OpenTable ("BookPaperLinks_Ranges")
0201 MsgBox ("Update the BookPaperLinks_Ranges Table.")
0202 End
0203 End If
0204 'Need to set a variable for later processing in loop
0205 Run_Type = "Ranges"
0206 strDataQuery = strDataQuery & "_Regen"
0207 Else
0208 Exit Sub
0209 End If
0210 End If
0211End If
0212Automation:
0213All_Done = False
0214StartTime = Now()
0215RunStartTime = Now()
0216If Run_Type = "Ranges" Then
0217 Set rsTableToRead3 = CurrentDb.OpenRecordset("SELECT * FROM BookPaperLinks_Ranges WHERE [Select?] = True ORDER BY ID_Start;")
0218 If rsTableToRead3.EOF Then
0219 All_Done = True
0220 Else
0221 rsTableToRead3.MoveFirst
0222 End If
0223End If
0224Do Until All_Done = True
0225 If Run_Type <> "Ranges" Then
0226 All_Done = True
0227 Else
0228 'Generate records list
0229 strControlQuery = "Select Current_ID.* FROM Current_ID; "
0230 Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery) 'Borrow this recordset!
0231 rsTableToRead.MoveFirst
0232 rsTableToRead.Edit
0233 rsTableToRead.Fields(0) = rsTableToRead3.Fields(0)
0234 rsTableToRead.Update
0235 'Set up the Regen table
0236 DoCmd.RunSQL ("DELETE Books_To_Regen.* FROM Books_To_Regen;")
0237 DoCmd.OpenQuery ("Book_Range_GEN")
0238 End If
0239 'Read the data
0240 Set rsTableToRead = CurrentDb.OpenRecordset(strDataQuery)
0241 BookID_Previous = 0
0242 If Not rsTableToRead.EOF Then
0243 rsTableToRead.MoveFirst
0244 iTableColumns = rsTableToRead.Fields.Count
0245 'Column 0 is the Book ID, Column 1 is the Paper ID
0246 BookID = 0 'There is no Book 0
0247 strFileSuffix = ""
0248 strFileBody = ""
0249 Do Until rsTableToRead.EOF
0250 BookID = rsTableToRead.Fields(0)
0251 PaperID = rsTableToRead.Fields(1)
0252 First_Paper = False
0253 If BookID_Previous <> BookID Then 'New Book
0254 'Write the previous Footer (except first time)
0255 First_Paper = True
0256 If BookID_Previous <> 0 Then
0257 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;"
0258 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0259 rsTableControl.MoveFirst
0260 Do While Not rsTableControl.EOF
0261 Time_Stamp = rsTableControl.Fields(0) & ""
0262 OK = Replace_Timestamp(Time_Stamp)
0263 tsTextFile.WriteLine Time_Stamp
0264 rsTableControl.MoveNext
0265 Loop
0266 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0267 iCount = iCount + 1
0268 End If
0269 BookID_Previous = BookID
0270 strFileSuffix_Previous = strFileSuffix
0271 strFileBody_Previous = strFileBody
0272 strFileSuffix = strOutputFileShort & "_" & BookID
0273 strFileBody = "BookSummary_" & Right((Int((BookID / 1000) + 1000000)), 2)
0274 'Create File
0275 Set tsTextFile = fsoTextFile.CreateTextFile(strOutputFolder & strFileBody & "\" & strFileSuffix & ".htm", True, True)
0276 'Page Header
0277 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;"
0278 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0279 rsTableControl.MoveFirst
0280 Do While Not rsTableControl.EOF
0281 strLine = rsTableControl.Fields(0) & ""
0282 x = InStr(1, strLine, "**BOOK**")
0283 If x > 0 Then
0284 'Add the Book author & title
0285 strLine = Left(strLine, x - 1) & rsTableToRead.Fields(3) & " <BR><BR>(" & rsTableToRead.Fields(2) & ") " & Mid(strLine, x + 8, Len(strLine))
0286 End If
0287 x = InStr(1, strLine, "**TITLE**")
0288 If x > 0 Then
0289 'Add the Book author & title
0290 strLine = Left(strLine, x - 1) & "" & rsTableToRead.Fields(3) & " (" & rsTableToRead.Fields(2) & ") - Theo Todman's Book Collection (Book to Paper Links)" & Mid(strLine, x + 9, Len(strLine))
0291 End If
0292 tsTextFile.WriteLine strLine
0293 rsTableControl.MoveNext
0294 Loop
0295 'Read Table-Control for rows
0296 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;"
0297 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0298 'Table Column Headings
0299 rsTableControl.MoveFirst
0300 Do While Not rsTableControl.EOF
0301 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0302 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0303 'Note: Fields start at 0, but the first two in the query are IDs, and the next two are the book author & title
0304 If iFieldNo > 0 And iFieldNo <= iTableColumns - 4 Then
0305 tsTextFile.WriteLine "<B> " & rsTableToRead.Fields(iFieldNo + 3).Name & "</B>"
0306 End If
0307 Else
0308 tsTextFile.WriteLine rsTableControl.Fields(0) & ""
0309 End If
0310 rsTableControl.MoveNext
0311 Loop
0312 End If
0313 'Ignore pseudo-papers associated with pseudo-books!
0314 Print_The_Paper = "Yes"
0315 If rsTableToRead.Fields(2) = rsTableToRead.Fields(4) And rsTableToRead.Fields(2) = "Various" And First_Paper = False Then 'Author of book = author of paper
0316 If rsTableToRead.Fields(3) = rsTableToRead.Fields(5) Then 'Title of book = title of paper
0317 Print_The_Paper = "No"
0318 End If
0319 End If
0320 If Print_The_Paper = "Yes" Then
0321 'Table Row
0322 rsTableControl.MoveFirst
0323 Do While Not rsTableControl.EOF
0324 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0325 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0326 If iFieldNo > 0 And iFieldNo <= iTableColumns - 4 Then
0327 If Len(rsTableToRead.Fields(iFieldNo + 3) & "") = 0 Then
0328 strLine = "."
0329 Else
0330 If rsTableToRead.Fields(iFieldNo + 3).Name = "Further Information" Then
0331 strLine = "<A HREF = ""../../PaperSummaries/PaperSummary_" & Right(Str(Int(PaperID / 1000) + 1000000), 2) & "/PaperSummary_" & PaperID & ".htm"">More</A>"
0332 If rsTableToRead.Fields(iFieldNo + 3).Value = "." Then
0333 Else
0334 strLine = strLine & "<br><A HREF = ""../../Abstracts/Abstract_" & Right(Str(Int(PaperID / 1000) + 1000000), 2) & "/Abstract_" & PaperID & ".htm"">" & IIf(rsTableToRead.Fields(iFieldNo + 3).Value = "Comment", "Comment", "Abstract") & "</A>"
0335 strLine = strLine & Replace(rsTableToRead.Fields(iFieldNo + 3).Value, "Comment", "")
0336 End If
0337 Else
0338 strLine = rsTableToRead.Fields(iFieldNo + 3)
0339 End If
0340 End If
0341 strLine = ReplaceCode(strLine, Chr(13) & Chr(10), "<BR>")
0342 tsTextFile.WriteLine strLine
0343 End If
0344 Else
0345 tsTextFile.WriteLine rsTableControl.Fields(0) & ""
0346 End If
0347 rsTableControl.MoveNext
0348 Loop
0349 End If
0350 rsTableToRead.MoveNext
0351 Loop
0352 'Write the Last Footer
0353 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;"
0354 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0355 rsTableControl.MoveFirst
0356 Do While Not rsTableControl.EOF
0357 Time_Stamp = rsTableControl.Fields(0) & ""
0358 OK = Replace_Timestamp(Time_Stamp)
0359 tsTextFile.WriteLine Time_Stamp
0360 rsTableControl.MoveNext
0361 Loop
0362 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0363 iCount = iCount + 1
0364 If Changed_Only = True Then
0365 'Re-Generate the Book_Papers_Full table, ready for comparison next run
0366 ' ... but regenerate any changed BookPaperAbstracts web pages first
0367 automatic_processing = "Yes"
0368 WebpageGenBookPaperAbstractsWebPages
0369 DoCmd.OpenQuery ("Book_Papers_Full_Zap")
0370 DoCmd.OpenQuery ("Book_Papers_Full_GEN")
0371 End If
0372 End If
0373 If Run_Type = "Ranges" Then
0374 'Update the BookPaperAbstract_Ranges Table
0375 Duration = Now() - StartTime
0376 Duration = Duration * 24 * 60
0377 Duration = Round(Duration, 1)
0378 RunDate = Now()
0379 rsTableToRead3.Edit
0380 rsTableToRead3.Fields(4) = RunDate
0381 rsTableToRead3.Fields(5) = Duration
0382 rsTableToRead3.Update
0383 'Read Next Range
0384 rsTableToRead3.MoveNext
0385 If rsTableToRead3.EOF Then
0386 All_Done = True
0387 End If
0388 StartTime = Now()
0389 End If
0390Loop
0391Set fsoTextFile = Nothing
0392Set tsTextFile = Nothing
0393Set rsTableToRead = Nothing
0394Set rsTableToRead2 = Nothing
0395Set rsTableToRead3 = Nothing
0396Set rsTableControl = Nothing
0397If automatic_processing <> "Yes" Then
0398 Duration = Round((Now() - RunStartTime) * 24 * 60, 1)
0399 If Duration < 1 Then
0400 Duration = Round((Now() - RunStartTime) * 24 * 60 * 60)
0401 MsgBox Now() & ": Books To Papers Links Webpage Creation Complete in " & Duration & " seconds. " & iCount & " pages output.", vbOKOnly, "Create Books To Papers Links Webpages"
0402 Else
0403 MsgBox Now() & ": Books To Papers Links Webpage Creation Complete in " & Duration & " minutes. " & iCount & " pages output.", vbOKOnly, "Create Books To Papers Links Webpages"
0404 End If
0405End If
0406End Sub

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



Source Code of: CreatePapersToNotesWebPages
Procedure Type: Public Sub
Module: New Code
Lines of Code: 194
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub CreatePapersToNotesWebPages(BookPaper)
0002'This is a new module to generate the pages that list the Notes associated with a particular Paper.
0003'It was based on Sub CreatePapersToBooksWebPages
0004'It has been generalised to work for BooksToNotes ... it uses "Paper" in variables
0005Dim fsoTextFile As FileSystemObject
0006Dim tsTextFile As TextStream
0007Dim rsTableToRead As Recordset
0008Dim rsTableControl As Recordset
0009Dim strControlQuery As String
0010Dim strLine As String
0011Dim iTableColumns As Integer
0012Dim iFieldNo As Integer
0013Dim x As Integer
0014Dim i As Integer
0015Dim NoteID As Integer
0016Dim PaperID As Integer
0017Dim PaperID_Previous As Integer
0018Dim strFileSuffix As String
0019Dim strFileBody As String
0020Dim SubDirectory As String
0021Dim StartTime As Double
0022Dim Saved_NoteID As Integer
0023Dim strTableRow As String
0024Dim Suffix As String
0025Dim Same_Note As String
0026Dim Note_HLink As String
0027Dim Section As String
0028Dim strNoteText As String
0029Dim Note_HLink_Suffix As Integer
0030Dim Time_Stamp As String
0031Dim strAuthors As String
0032Set fsoTextFile = New FileSystemObject
0033strFolder = strOutputFolder
0034StartTime = Now()
0035Select Case BookPaper
0036 Case "Book"
0037 BooksToNotes_Prelims
0038 Case "Paper"
0039 PapersToNotes_Prelims
0040End Select
0041'Read the data
0042Set rsTableToRead = CurrentDb.OpenRecordset(strDataQuery)
0043rsTableToRead.MoveFirst
0044iTableColumns = rsTableToRead.Fields.Count - 2
0045'Column 0 is the Paper ID, Column 1 is the Note ID
0046'Don't display the last two columns (Note suffix - 0 for Live Note, Timestamp for Archived Notes - and Section number)
0047NoteID = 0 'There is no Note 0
0048strFileSuffix = ""
0049strFileBody = ""
0050Saved_NoteID = 0
0051strTableRow = ""
0052Do Until rsTableToRead.EOF
0053 PaperID = rsTableToRead.Fields(0)
0054 NoteID = rsTableToRead.Fields(1)
0055 Suffix = rsTableToRead.Fields(iTableColumns)
0056 ' Need to find if this is the same note as the previous one. If it is, we want multiple references on the same row ... ie. "(2), (3), ...
0057 If PaperID_Previous <> PaperID Then 'New Paper
0058 Same_Note = "No"
0059 Else
0060 If NoteID = Saved_NoteID Then
0061 Same_Note = "Yes"
0062 Else
0063 Same_Note = "No"
0064 End If
0065 End If
0066 Saved_NoteID = NoteID
0067 If Same_Note = "No" Then
0068 'Determine Note Group & Non-Sub-directory
0069 SubDirectory = Find_New_Directory(NoteID)
0070 If rsTableToRead.Fields(5) = "Supervisions" Then
0071 SubDirectory = "/Secure_Jen/Notes_" & SubDirectory
0072 Else
0073 SubDirectory = "/Notes/Notes_" & SubDirectory
0074 End If
0075 End If
0076 If PaperID_Previous <> PaperID Then 'New Paper
0077 'Write the previous Footer (except first time)
0078 If PaperID_Previous <> 0 Then
0079 'First need to write out the last table row
0080 strTableRow = ReplaceCode(strTableRow, Chr(13) & Chr(10), "<BR>")
0081 strTableRow = ReplaceCode(strTableRow, "xyzabc123", Note_HLink)
0082 tsTextFile.WriteLine strTableRow
0083 strTableRow = ""
0084 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;"
0085 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0086 rsTableControl.MoveFirst
0087 Do While Not rsTableControl.EOF
0088 Time_Stamp = rsTableControl.Fields(0) & ""
0089 OK = Replace_Timestamp(Time_Stamp)
0090 tsTextFile.WriteLine Time_Stamp
0091 rsTableControl.MoveNext
0092 Loop
0093 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0094 End If
0095 PaperID_Previous = PaperID
0096 strFileSuffix = strOutputFileShort & "_" & PaperID
0097 strFileBody = BookPaper & "Summary_" & Right((Int((PaperID / 1000) + 1000000)), 2)
0098 'Create File
0099 Set tsTextFile = fsoTextFile.CreateTextFile(strOutputFolder & strFileBody & "\" & strFileSuffix & ".htm", True, True)
0100 'Page Header
0101 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;"
0102 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0103 rsTableControl.MoveFirst
0104 Do While Not rsTableControl.EOF
0105 strLine = rsTableControl.Fields(0) & ""
0106 x = InStr(1, strLine, "**" & BookPaper & "**")
0107 If x > 0 Then
0108 'Add the Paper author & title
0109 strAuthors = rsTableToRead.Fields(2)
0110 OK = Author_Reference_String(strAuthors, 2)
0111 strLine = Left(strLine, x - 1) & "<A HREF=""" & BookPaper & "Summary_" & PaperID & ".htm"">" & rsTableToRead.Fields(3) & "</a> <BR><BR>(" & strAuthors & ") " & Mid(strLine, x + 9, Len(strLine))
0112 End If
0113 tsTextFile.WriteLine strLine
0114 rsTableControl.MoveNext
0115 Loop
0116 'Read Table-Control for rows
0117 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;"
0118 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0119 'Table Column Headings
0120 rsTableControl.MoveFirst
0121 Do While Not rsTableControl.EOF
0122 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0123 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0124 'Note: Fields start at 0, but the first two in the query are IDs, and the next two are the book author & title
0125 If iFieldNo > 0 And iFieldNo <= iTableColumns - 4 Then
0126 tsTextFile.WriteLine "<B> " & rsTableToRead.Fields(iFieldNo + 3).Name & "</B>"
0127 End If
0128 Else
0129 tsTextFile.WriteLine rsTableControl.Fields(0) & ""
0130 End If
0131 rsTableControl.MoveNext
0132 Loop
0133 End If
0134 'Table Row
0135 'First need to write out the last table row, if relevant
0136 If Same_Note = "No" Then
0137 strTableRow = ReplaceCode(strTableRow, Chr(13) & Chr(10), "<BR>")
0138 strTableRow = ReplaceCode(strTableRow, "xyzabc123", Note_HLink)
0139 tsTextFile.WriteLine strTableRow
0140 strTableRow = ""
0141 End If
0142 rsTableControl.MoveFirst
0143 Do While Not rsTableControl.EOF
0144 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0145 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0146 If iFieldNo > 0 And iFieldNo <= iTableColumns - 4 Then
0147 If Len(rsTableToRead.Fields(iFieldNo + 3) & "") = 0 Then
0148 If Same_Note = "No" Then
0149 strTableRow = strTableRow & "."
0150 End If
0151 Else
0152 If rsTableToRead.Fields(iFieldNo + 3).Name = "Note" Then
0153 Section = rsTableToRead.Fields(iTableColumns + 1)
0154 strNoteText = rsTableToRead.Fields(iFieldNo + 3)
0155 If Same_Note = "No" Then
0156 strTableRow = strTableRow & "xyzabc123"
0157 Note_HLink_Suffix = 1
0158 Note_HLink = "<A HREF = ""../.." & SubDirectory & "/Notes_" & NoteID & IIf(Suffix > 0, "_" & Suffix, "") & ".htm" & IIf(Section > 0, "#" & Section, "") & """>" & strNoteText & "</A>"
0159 Else
0160 Note_HLink_Suffix = Note_HLink_Suffix + 1
0161 Note_HLink = Note_HLink & ", also (<A HREF = ""../.." & SubDirectory & "/Notes_" & NoteID & IIf(Suffix > 0, "_" & Suffix, "") & ".htm" & IIf(Section > 0, "#" & Section, "") & """>" & Note_HLink_Suffix & "</A>)"
0162 End If
0163 Else
0164 If Same_Note = "No" Then
0165 strTableRow = strTableRow & rsTableToRead.Fields(iFieldNo + 3)
0166 End If
0167 End If
0168 End If
0169 End If
0170 Else
0171 If Same_Note = "No" Then
0172 strTableRow = strTableRow & rsTableControl.Fields(0) & ""
0173 End If
0174 End If
0175 rsTableControl.MoveNext
0176 Loop
0177 rsTableToRead.MoveNext
0178Loop
0179'Write the Last Footer
0180'First need to write out the last table row
0181 strTableRow = ReplaceCode(strTableRow, Chr(13) & Chr(10), "<BR>")
0182 strTableRow = ReplaceCode(strTableRow, "xyzabc123", Note_HLink)
0183tsTextFile.WriteLine strTableRow
0184 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;"
0185Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0186rsTableControl.MoveFirst
0187Do While Not rsTableControl.EOF
0188 Time_Stamp = rsTableControl.Fields(0) & ""
0189 OK = Replace_Timestamp(Time_Stamp)
0190 tsTextFile.WriteLine Time_Stamp
0191 rsTableControl.MoveNext
0192Loop
0193 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0194End Sub

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



Source Code of: Find_Book_Paper_Links
Procedure Type: Public Sub
Module: New Code
Lines of Code: 37
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Find_Book_Paper_Links()
0002Dim rsTableToRead As Recordset
0003Dim rsTableToWrite As Recordset
0004Dim x As Integer
0005Dim Y As Integer
0006Dim iBook As Integer
0007Dim iPaper As Integer
0008Dim strLine As String
0009 Set rsTableToRead = CurrentDb.OpenRecordset("PapersWithBookLinks")
0010rsTableToRead.MoveFirst
0011 DoCmd.RunSQL ("DELETE * FROM Book_Papers;")
0012 Set rsTableToWrite = CurrentDb.OpenRecordset("SELECT * FROM Book_Papers;")
0013Do While Not rsTableToRead.EOF
0014 iPaper = rsTableToRead.Fields(0)
0015 strLine = rsTableToRead.Fields(1)
0016 x = 1
0017 Do While x > 0
0018 x = InStr(x, strLine, "+B")
0019 If x > 0 Then
0020 Y = InStr(x, strLine, "B+")
0021 If Y > 0 Then
0022 iBook = Mid(strLine, x + 2, Y - x - 2)
0023 'Write out a record
0024 rsTableToWrite.AddNew
0025 rsTableToWrite.Fields(0) = iBook
0026 rsTableToWrite.Fields(1) = iPaper
0027 rsTableToWrite.Fields(2) = Now()
0028 rsTableToWrite.Update
0029 End If
0030 x = x + 1
0031 End If
0032 Loop
0033 rsTableToRead.MoveNext
0034Loop
0035Set rsTableToRead = Nothing
0036Set rsTableToWrite = Nothing
0037End Sub

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



© Theo Todman, June 2007 - Oct 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