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