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: 726
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 Else
0196 If MsgBox("Would you like to re-create only books with changed Books to Papers Links? If so, respond ""Yes"". ", vbYesNo) = vbYes Then
0197 strDataQuery = strDataQuery & "_Changed"
0198 End If
0199 End If
0200 Else
0201 If MsgBox("Would you like to re-create only books with changed Books to Papers Links? If so, respond ""Yes"". ", vbYesNo) = vbYes Then
0202 strDataQuery = strDataQuery & "_Changed"
0203 Else
0204 'New Code ... check for ranges
0205 If MsgBox("Would you like to re-create book-paper abstracts within ID ranges? If so, respond ""Yes"". ", vbYesNo) = vbYes Then
0206 strDataQuery = strDataQuery & "_Range"
0207 'Set the range(s)
0208 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM BookPaperAbstract_Ranges WHERE [Select?] = True ORDER BY ID_Start;")
0209 If Not rsTableToRead.EOF Then
0210 rsTableToRead.MoveFirst
0211 strMessage = "Run for the following range" & IIf(rsTableToRead.RecordCount > 1, "s", "") & "?" & Chr(10) & Chr(10)
0212 Do While Not rsTableToRead.EOF
0213 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)
0214 Total_Run = Total_Run + rsTableToRead.Fields(5)
0215 rsTableToRead.MoveNext
0216 Loop
0217 strMessage = strMessage & "Total time = " & Round(Total_Run, 0) & " mins." & Chr(10) & Chr(10)
0218 Else
0219 DoCmd.OpenTable ("BookPaperAbstract_Ranges")
0220 MsgBox ("No Ranges selected. Update the BookPaperAbstract_Ranges Table.")
0221 End
0222 End If
0223 Total_Run = 0
0224 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM BookPaperAbstract_Ranges WHERE [Select?] = False ORDER BY ID_Start;")
0225 If Not rsTableToRead.EOF Then
0226 strMessage = strMessage & "Not selected:- " & Chr(10) & Chr(10)
0227 rsTableToRead.MoveFirst
0228 Do While Not rsTableToRead.EOF
0229 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)
0230 Total_Run = Total_Run + rsTableToRead.Fields(5)
0231 rsTableToRead.MoveNext
0232 Loop
0233 strMessage = strMessage & "Total time outstanding = " & Round(Total_Run, 0) & " mins." & Chr(10) & Chr(10)
0234 End If
0235 Response = MsgBox(strMessage, vbYesNo)
0236 If Response = vbNo Then
0237 DoCmd.OpenTable ("BookPaperAbstract_Ranges")
0238 MsgBox ("Update the BookPaperAbstract_Ranges Table.")
0239 End
0240 End If
0241 'Need to set a variable for later processing in loop
0242 Run_Type = "Ranges"
0243 Else
0244 If MsgBox("Would you like to re-create All Book-Paper Abstracts - this will take many hours? If so, respond ""Yes"". ", vbYesNo) <> vbYes Then
0245 MsgBox ("Try again")
0246 Exit Sub
0247 End If
0248 End If
0249 End If
0250 End If
0251Else
0252 strDataQuery = strDataQuery & "_Changed"
0253End If
0254Automatic:
0255All_Done = False
0256StartTime = Now()
0257RunStartTime = Now()
0258BookID = 0 'There is no Book 0
0259strFileSuffix = ""
0260strFileBody = ""
0261Pseudo_Book = False
0262 OK = Convert_Webrefs("Book", "Full")
0263If Run_Type = "Ranges" Then
0264 Set rsTableToRead3 = CurrentDb.OpenRecordset("SELECT * FROM BookPaperAbstract_Ranges WHERE [Select?] = True ORDER BY ID_Start;")
0265 If rsTableToRead3.EOF Then
0266 All_Done = True
0267 Else
0268 rsTableToRead3.MoveFirst
0269 End If
0270End If
0271Do Until All_Done = True
0272 If Run_Type <> "Ranges" Then
0273 All_Done = True
0274 Else
0275 'Generate records list
0276 strControlQuery = "Select Current_ID.* FROM Current_ID; "
0277 Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery) 'Borrow this recordset!
0278 rsTableToRead.MoveFirst
0279 rsTableToRead.Edit
0280 rsTableToRead.Fields(0) = rsTableToRead3.Fields(0)
0281 rsTableToRead.Update
0282 End If
0283 'Read the data
0284 Set rsTableToRead = CurrentDb.OpenRecordset(strDataQuery)
0285 'Column 0 is the Book ID, Column 1 is the Paper ID
0286 iDepth = 3
0287 If Not rsTableToRead.EOF Then
0288 rsTableToRead.MoveFirst
0289 iTableColumns = rsTableToRead.Fields.Count
0290 Do Until rsTableToRead.EOF
0291 BookID = rsTableToRead.Fields(0)
0292 PaperID = rsTableToRead.Fields(1)
0293 If BookID_Previous <> BookID Then 'New Book
0294 'Write the previous Footer (except first time)
0295 If BookID_Previous <> 0 Then
0296 If Pseudo_Book = True Then
0297 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."
0298 Else
0299 strLine = ""
0300 End If
0301 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"">"
0302 For i = 0 To 19
0303 If Colour_Table(i, 4) = "1" Then
0304 strLine = strLine & "<LI><FONT COLOR = """ & Colour_Table(i, 1) & """>" & Colour_Table(i, 2) & "</FONT>: " & Colour_Table(i, 3) & "</li>"
0305 End If
0306 Next i
0307 strLine = strLine & "</OL>"
0308 OK = TrimBranches(strLine)
0309 tsTextFile.WriteLine strLine
0310 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;"
0311 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0312 rsTableControl.MoveFirst
0313 Do While Not rsTableControl.EOF
0314 strLine = rsTableControl.Fields(0) & ""
0315 OK = Replace_Timestamp(strLine)
0316 OK = TrimBranches(strLine)
0317 tsTextFile.WriteLine strLine
0318 rsTableControl.MoveNext
0319 Loop
0320 If Test_Flag = True Then
0321 sw2.StartTimer
0322 End If
0323 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0324 If Test_Flag = True Then
0325 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " CopyToTransfer"
0326 Debug.Print Now(); strFileSuffix; sw.EndTimer; "Milliseconds"
0327 Stop
0328 sw.StartTimer
0329 End If
0330 iCount = iCount + 1
0331 Else
0332 If Test_Flag = True Then
0333 sw.StartTimer
0334 End If
0335 End If
0336 Print_The_First_Paper = "Yes"
0337 'Ignore "dummy" papers with no Comment or Abstract
0338 If rsTableToRead.Fields(11) & "" = "" And rsTableToRead.Fields(12) & "" = "" Then
0339 If rsTableToRead.Fields(2) = rsTableToRead.Fields(4) Then 'Author of book = author of paper
0340 If rsTableToRead.Fields(3) = rsTableToRead.Fields(5) Then 'Title of book = title of paper
0341 Print_The_First_Paper = "No"
0342 End If
0343 End If
0344 End If
0345 'Ignore the papers in pseudo-books
0346 If rsTableToRead.Fields(17) = "Yes" Then
0347 Print_The_First_Paper = "No"
0348 Pseudo_Book = True
0349 Else
0350 Pseudo_Book = False
0351 End If
0352 BookID_Previous = BookID
0353 Clear_Colour_Usage
0354 strFileSuffix_Previous = strFileSuffix
0355 strFileBody_Previous = strFileBody
0356 strFileSuffix = strOutputFileShort & "_" & BookID
0357 strFileBody = "BookSummary_" & Right((Int((BookID / 1000) + 1000000)), 2) & "\BookPaperAbstracts"
0358 'Create File
0359 Set tsTextFile = fsoTextFile.CreateTextFile(strOutputFolder & strFileBody & "\" & strFileSuffix & ".htm", True, True)
0360 Link_Count = 0
0361 Link_1 = ""
0362 Link_2 = ""
0363 Link_3 = ""
0364 Link_4 = ""
0365 Link_5 = ""
0366 Link_6 = ""
0367 Link_Authors = ""
0368 'Page Header
0369 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;"
0370 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0371 rsTableControl.MoveFirst
0372 Do While Not rsTableControl.EOF
0373 strLine = rsTableControl.Fields(0) & ""
0374 x = InStr(1, strLine, "**BOOK**")
0375 If x > 0 Then
0376 If Test_Flag = True Then
0377 sw2.StartTimer
0378 End If
0379 strLine = ""
0380 'Determine whether to output the link to page-end for the colour-conventions
0381 qryString = rsTableToRead.Name
0382 Set_Colour_Link = "No"
0383 If rsTableToRead.Fields(iTableColumns - 2) > 500 Then
0384 Set_Colour_Link = "Yes"
0385 Else
0386 strQuery = "SELECT " & qryString & ".[Book ID], Count(" & qryString & ".[Paper ID]) AS [CountOfPaper ID], " & qryString & ".Book_BlurbLen, Sum(" & qryString & ".Paper_BlurbLen) AS SumOfPaper_BlurbLen FROM " & qryString & " GROUP BY " & qryString & ".[Book ID], " & qryString & ".Book_BlurbLen HAVING (((" & qryString & ".[Book ID])=" & BookID & "));"
0387 Set rsColourCheck = CurrentDb.OpenRecordset(strQuery)
0388 rsColourCheck.MoveFirst
0389 If rsColourCheck.Fields(1) > 2 Or (rsColourCheck.Fields(2) + rsColourCheck.Fields(3)) > 500 Then
0390 Set_Colour_Link = "Yes"
0391 End If
0392 Set rsColourCheck = Nothing
0393 End If
0394 If Test_Flag = True Then
0395 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " Book"
0396 End If
0397 strAuthors = rsTableToRead.Fields(2)
0398 OK = Author_Reference_String(strAuthors, 3)
0399 'Add the Book author & title + Link to Colour Conventions (if required ...)
0400 Link_1 = "<A HREF = """ & "../BookSummary_" & BookID & ".htm" & """>" & rsTableToRead.Fields(3) & "</A>"
0401 Link_2 = strAuthors
0402 If Set_Colour_Link = "Yes" Then
0403 Link_3 = "<A HREF=""#ColourConventions"">Colour-Conventions</a>"
0404 Link_Count = Link_Count + 1
0405 End If
0406 End If
0407 x = InStr(1, strLine, "**TITLE**")
0408 If x > 0 Then
0409 'Add the Book author & title
0410 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))
0411 End If
0412 OK = TrimBranches(strLine)
0413 tsTextFile.WriteLine strLine
0414 rsTableControl.MoveNext
0415 Loop
0416 'Output Book, Paper & Notes citing links
0417 If Test_Flag = True Then
0418 sw2.StartTimer
0419 End If
0420 strControlQuery = "SELECT Book_Citings_List_New.* FROM Book_Citings_List_New WHERE Book_Citings_List_New.Book_ID = " & rsTableToRead.Fields(0) & ";"
0421 Set rsCitings = CurrentDb.OpenRecordset(strControlQuery)
0422 If Not rsCitings.EOF Then
0423 rsCitings.MoveFirst
0424 Link_4 = "<A HREF = ""../BookCitings_" & rsTableToRead.Fields(0) & ".htm"">Books / Papers Citing this Book</A>"
0425 Link_Count = Link_Count + 1
0426 Set rsCitings = Nothing
0427 End If
0428 If Test_Flag = True Then
0429 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " Book_Citings"
0430 End If
0431 If Test_Flag = True Then
0432 sw2.StartTimer
0433 End If
0434 strControlQuery = "SELECT Book_Note_Counts.* FROM Book_Note_Counts WHERE Book_Note_Counts.Book = " & rsTableToRead.Fields(0) & ";"
0435 Set rsCitings = CurrentDb.OpenRecordset(strControlQuery)
0436 If Not rsCitings.EOF Then
0437 rsCitings.MoveFirst
0438 Link_5 = "<A HREF = ""../BooksToNotes_" & rsTableToRead.Fields(0) & ".htm"">Notes Citing this Book</A>"
0439 Link_Count = Link_Count + 1
0440 Set rsCitings = Nothing
0441 End If
0442 If Test_Flag = True Then
0443 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " Book_Note_Counts"
0444 End If
0445 If Link_3 <> "" Or InStr(rsTableToRead.Fields(9) & "", "|Colour_2|") > 0 Or InStr(rsTableToRead.Fields(10) & "", "|Colour_2|") > 0 Then
0446 Link_6 = "<A HREF=""../../../Notes/Notes_10/Notes_1025.htm"">Disclaimer</a>"
0447 Link_Count = Link_Count + 1
0448 End If
0449 strTable = "<hr><CENTER><TABLE class = ""Bridge"" WIDTH=950>"
0450 If Link_1 <> "" Then
0451 strTable = strTable & "<tr><td colspan =" & IIf(Link_Count > 0, Link_Count, 1) & ">" & Link_1 & "</td></tr>"
0452 End If
0453 If Link_2 <> "" Then
0454 strTable = strTable & "<tr><td colspan =" & IIf(Link_Count > 0, Link_Count, 1) & ">" & Link_2 & "</td></tr>"
0455 End If
0456 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>"
0457 If Link_Count > 0 Then
0458 strTable = strTable & "<tr>"
0459 If Link_3 <> "" Then
0460 strTable = strTable & "<td>" & Link_3 & "</td>"
0461 End If
0462 If Link_6 <> "" Then
0463 strTable = strTable & "<td>" & Link_6 & "</td>"
0464 End If
0465 If Link_4 <> "" Then
0466 strTable = strTable & "<td>" & Link_4 & "</td>"
0467 End If
0468 If Link_5 <> "" Then
0469 strTable = strTable & "<td>" & Link_5 & "</td>"
0470 End If
0471 strTable = strTable & "</tr>"
0472 End If
0473 strTable = strTable & "</tr></TABLE></CENTER><hr>"
0474 tsTextFile.WriteLine strTable
0475 'Add Author Citings
0476 If Test_Flag = True Then
0477 sw2.StartTimer
0478 End If
0479 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;"
0480 Set rsCitings = CurrentDb.OpenRecordset(strControlQuery)
0481 If Not rsCitings.EOF Then
0482 rsCitings.MoveFirst
0483 strLine = "<B>Authors Citing this Book</B>: "
0484 strLine = strLine & "<A HREF = ""../../../Authors/" & Left(rsCitings.Fields(0), 1) & "/Author_" & rsCitings.Fields(0) & ".htm"">" & rsCitings.Fields(0) & "</A>"
0485 rsCitings.MoveNext
0486 Do While Not rsCitings.EOF
0487 strLine = strLine & ", <A HREF = ""../../../Authors/" & Left(rsCitings.Fields(0), 1) & "/Author_" & rsCitings.Fields(0) & ".htm"">" & rsCitings.Fields(0) & "</A>"
0488 rsCitings.MoveNext
0489 Loop
0490 strLine = "<p>" & strLine & "</p><hr>"
0491 tsTextFile.WriteLine strLine
0492 Set rsCitings = Nothing
0493 End If
0494 If Test_Flag = True Then
0495 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " Author Citings"
0496 End If
0497 'Book Abstract
0498 OK = Zap_Cross_References("B", BookID, 0)
0499 NameRef = 0
0500 strText = ""
0501 strAbstract = Trim(rsTableToRead.Fields(9) & "")
0502 If Len(strAbstract) > 0 Then
0503 OK = Reference_FootNotes("B", BookID, strAbstract, "+B" & BookID & "B+")
0504 strText = "|Colour_1|<B>BOOK ABSTRACT: </B>" & IIf(Left(strAbstract, 1) = "|", "", "<BR><BR>") & strAbstract
0505 Else
0506 strText = "|Colour_1|<B>BOOK ABSTRACT: </B>None."
0507 End If
0508 'Write out Comment
0509 strComment = Trim(rsTableToRead.Fields(10) & "")
0510 If Len(strComment) > 0 Then
0511 strText = strText & "|Colour_1|<HR><B>BOOK COMMENT: </B>" & IIf(Left(strComment, 1) = "|", "", "<BR><BR>") & strComment
0512 End If
0513 'Format & Write out
0514 strLine = "<P ALIGN = ""Justify""><FONT Size = 2 FACE=""Arial"">" & strText & "</P>"
0515 strLine = Remove_Dummy_Ref(strLine)
0516 strLine = WebEncode(strLine)
0517 OK = Reference_Notes(strLine, "B", BookID, 0, iDepth) 'Replace the Notes References by hyperlinks
0518 OK = Reference_Notes(strLine, "B", BookID, 0, iDepth, "Abstract_Direct") 'Replace the Notes References by hyperlinks
0519 OK = Reference_Papers(strLine, "B", BookID, 0, iDepth) 'Replace the Papers References by hyperlinks
0520 OK = Reference_Author(strLine, "B", BookID, 0, iDepth) 'Replace the Author References by hyperlinks
0521 OK = Reference_Note_Links(strLine, "B", BookID, 0) 'Replace the Note Link References by hyperlinks
0522 OK = Reference_Books(strLine, "B", BookID, 0, iDepth) 'Replace the Books References by hyperlinks
0523 'Encode any unencoded references first - otherwise they never get encoded!
0524 OK = Reference_Webrefs(strLine, "B", BookID, 0)
0525 strLine = ReplaceCode(strLine, Chr(13) & Chr(10), "<BR>")
0526 strLine = NumberedBullets(strLine)
0527 strLine = Bullets(strLine)
0528 OK = Mark_Colours(strLine)
0529 OK = TrimBranches(strLine)
0530 tsTextFile.WriteLine strLine
0531 If Test_Flag = True Then
0532 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " Book Abstract"
0533 End If
0534 'Log Referencing Changes
0535 If Full_Regen = False Then
0536 DoCmd.OpenQuery ("Cross_Reference_Changes_Deletions_Add")
0537 DoCmd.OpenQuery ("Cross_Reference_Changes_Additions_Add")
0538 If Test_Flag = True Then
0539 Debug.Print Now(); strFileSuffix; sw2.EndTimer; "Milliseconds"; " Cross_Reference_Changes"
0540 End If
0541 End If
0542 End If
0543 'Paper Abstracts
0544 If Print_The_First_Paper = "Yes" Then
0545 'Determine Paper Title
0546 PaperTitle = ""
0547 PaperRef = rsTableToRead.Fields(1)
0548 qryString = "SELECT Papers.Author, Papers.Title, Papers.Abstract_Quality FROM Papers WHERE (((Papers.ID)=" & PaperRef & "));"
0549 Set rsTableToRead2 = CurrentDb.OpenRecordset(qryString)
0550 If Not rsTableToRead2.EOF Then
0551 rsTableToRead2.MoveFirst
0552 PaperTitle = rsTableToRead2.Fields(0).Value & " - " & rsTableToRead2.Fields(1).Value
0553 z = Str(Int(PaperRef / 1000) + 1000000)
0554 strText = "|Colour_1|<HR><BR>""<B><A HREF = """ & "../../PaperSummaries/PaperSummary_" & Right(z, 2) & "/PaperSummary_" & PaperRef & ".htm"">" & PaperTitle & "</A></B>""<BR>"
0555 Else
0556 PaperTitle = """Unknown Paper"""
0557 strText = "|Colour_1|<HR><BR><B>" & PaperTitle & "</B><BR>"
0558 End If
0559 Set rsTableToRead2 = Nothing
0560 If rsTableToRead.Fields(6) & "" <> "" Then
0561 strText = strText & "<BR><B>" & "Source</B>: " & rsTableToRead.Fields(6) & "<BR>"
0562 Else
0563 strText = strText & "<BR>"
0564 End If
0565 If rsTableToRead.Fields(16) & "" = "" Then
0566 strWriteUp_Note = ""
0567 Else
0568 strWriteUp_Note = "Write-up Note++" & rsTableToRead.Fields(16) & "++ (Full Text reproduced below). "
0569 End If
0570 strAbstract = Trim(rsTableToRead.Fields(11) & "")
0571 strComment = Trim(rsTableToRead.Fields(12) & "")
0572 If Len(strComment) > 5000 Then
0573 strAbstract = strAbstract & strComment
0574 strComment = ""
0575 End If
0576 If strAbstract <> "" Then
0577 If Len(strAbstract) > 0 Then
0578 BlankSpace = Left(strAbstract, 4)
0579 If BlankSpace = "|..|" Or BlankSpace = "|99|" Or BlankSpace = "|ii|" Or BlankSpace = "|II|" Or BlankSpace = "|aa|" Or BlankSpace = "|AA|" Or BlankSpace = "|##|" Then
0580 BlankSpace = ""
0581 Else
0582 BlankSpace = "<BR><BR>"
0583 End If
0584 strText = strText & "|Colour_1|" & strWriteUp_Note & BlankSpace & strAbstract
0585 Else
0586 If strWriteUp_Note <> "" Then
0587 strText = strText & "|Colour_1|" & strWriteUp_Note & "<BR><BR>"
0588 End If
0589 End If
0590 Else
0591 If strWriteUp_Note <> "" Then
0592 strText = strText & "|Colour_1|" & strWriteUp_Note & "<BR><BR>"
0593 End If
0594 End If
0595 If rsTableToRead.Fields(12) & "" <> "" Then
0596 If Len(strComment) > 0 And Len(strComment) <= 5000 Then
0597 If Len(Trim(strAbstract)) > 0 Then
0598 strText = strText & "<BR><BR>"
0599 End If
0600 strText = strText & "|Colour_1|<B>COMMENT: </B>" & strComment
0601 End If
0602 End If
0603 'Add the Write-up Note (if any)
0604 If strWriteUp_Note <> "" Then
0605 strQuery = "SELECT Notes.ID, Notes.Item_Title, Notes.Item_Text, Notes.Last_Changed, Notes.[Private?] FROM Notes WHERE (((Notes.ID)=" & rsTableToRead.Fields(16) & "));"
0606 Set rsNote = CurrentDb.OpenRecordset(strQuery)
0607 If Not rsNote.EOF Then
0608 If rsNote.Fields(4) & "" = "No" Then
0609 strNote_Date = rsNote.Fields(3) & ""
0610 If strNote_Date <> "" Then
0611 strNote_Date = CDate(strNote_Date / 1000)
0612 Else
0613 strNote_Date = Now()
0614 End If
0615 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) & "));"
0616 Set rsNote2 = CurrentDb.OpenRecordset(strQuery)
0617 SubDirectory = Find_New_Directory(rsTableToRead.Fields(16))
0618 SubDirectory = SubDirectory & "/Notes_"
0619 If rsNote2.Fields(0) = "Supervisions" Then
0620 SubDirectory = "../../Secure_Jen/Notes_" & SubDirectory
0621 Else
0622 SubDirectory = "../../Notes/Notes_" & SubDirectory
0623 End If
0624 Link_4 = "<A HREF = """ & SubDirectory & rsTableToRead.Fields(16).Value & ".htm"">Link to Latest Write-Up Note</A>"
0625 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)
0626 End If
0627 End If
0628 Set rsNote = Nothing
0629 Set rsNote2 = Nothing
0630 End If
0631 'Format & Write out
0632 strText = Remove_Dummy_Ref(strText)
0633 strText = WebEncode(strText)
0634 strLine = "<P ALIGN = ""Justify""><FONT Size = 2 FACE=""Arial"">" & strText & "</P>"
0635 strLine = ReplaceCode(strLine, """../", """../../") '... because we're down a directory-level
0636 OK = Reference_FootNotes("P", rsTableToRead.Fields(1), strLine, "+P" & rsTableToRead.Fields(1) & "P+")
0637 OK = Reference_Notes(strLine, "X", 0, 0, iDepth, "Abstract_Direct") 'Replace the Notes References by hyperlinks
0638 OK = Reference_Notes(strLine, "X", 0, 0, iDepth) 'Replace the Notes References by hyperlinks
0639 OK = Reference_Author(strLine, "X", 0, 0, iDepth) 'Replace the Author References by hyperlinks
0640 OK = Reference_Note_Links(strLine, "B", 0, 0) 'Replace the Note Link References by hyperlinks
0641 OK = Reference_Papers(strLine, "X", 0, 0, iDepth) 'Replace the Papers References by hyperlinks
0642 OK = Reference_Books(strLine, "X", 0, 0, iDepth) 'Replace the Books References by hyperlinks
0643 OK = Reference_Webrefs(strLine, "X", 0, 0)
0644 strLine = ReplaceCode(strLine, Chr(13) & Chr(10), "<BR>")
0645 strLine = NumberedBullets(strLine)
0646 strLine = Bullets(strLine)
0647 OK = Mark_Colours(strLine)
0648 OK = TrimBranches(strLine)
0649 tsTextFile.WriteLine strLine
0650 Else
0651 If rsTableToRead.Fields(17) = "No" Then
0652 Print_The_First_Paper = "Yes" 'Flag further papers as printable
0653 End If
0654 End If
0655 'Next Record
0656 rsTableToRead.MoveNext
0657 Loop
0658 'Write the Last Footer
0659 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;"
0660 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0661 If Pseudo_Book = True Then
0662 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."
0663 Else
0664 strLine = ""
0665 End If
0666 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"">"
0667 For i = 0 To 19
0668 If Colour_Table(i, 4) = "1" Then
0669 strLine = strLine & "<LI><FONT COLOR = """ & Colour_Table(i, 1) & """>" & Colour_Table(i, 2) & "</FONT>: " & Colour_Table(i, 3) & "</li>"
0670 End If
0671 Next i
0672 strLine = strLine & "</OL>"
0673 OK = TrimBranches(strLine)
0674 tsTextFile.WriteLine strLine
0675 rsTableControl.MoveFirst
0676 Do While Not rsTableControl.EOF
0677 strLine = rsTableControl.Fields(0) & ""
0678 OK = Replace_Timestamp(strLine)
0679 OK = TrimBranches(strLine)
0680 tsTextFile.WriteLine strLine
0681 rsTableControl.MoveNext
0682 Loop
0683 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0684 iCount = iCount + 1
0685 End If
0686 If Run_Type = "Ranges" Then
0687 'Update the BookPaperAbstract_Ranges Table
0688 Duration = Now() - StartTime
0689 Duration = Duration * 24 * 60
0690 Duration = Round(Duration, 1)
0691 RunDate = Now()
0692 rsTableToRead3.Edit
0693 rsTableToRead3.Fields(4) = RunDate
0694 rsTableToRead3.Fields(5) = Duration
0695 rsTableToRead3.Update
0696 'Read Next Range
0697 rsTableToRead3.MoveNext
0698 If rsTableToRead3.EOF Then
0699 All_Done = True
0700 End If
0701 StartTime = Now()
0702 End If
0703Loop
0704Set fsoTextFile = Nothing
0705Set tsTextFile = Nothing
0706Set rsTableToRead = Nothing
0707Set rsTableToRead2 = Nothing
0708Set rsTableToRead3 = Nothing
0709Set rsTableControl = Nothing
0710Cross_Reference_Table_Open = False
0711Set rsCross_Reference_Table = Nothing
0712 DoCmd.OpenQuery ("Cross_Reference_Idempotency_Zap")
0713If Test_Flag = True Then
0714 Set sw = Nothing
0715 Set sw2 = Nothing
0716End If
0717Duration = Round((Now() - RunStartTime) * 24 * 60, 1)
0718If automatic_processing <> "Full" And automatic_processing <> "Yes" Then
0719 If Duration < 1 Then
0720 Duration = Round((Now() - RunStartTime) * 24 * 60 * 60)
0721 MsgBox Now() & ": Printable Book Paper Abstracts Webpage Creation Complete in " & Duration & " seconds. " & iCount & " pages output.", vbOKOnly, "Create Book Paper Abstracts Web Pages"
0722 Else
0723 MsgBox Now() & ": Printable Book Paper Abstracts Webpage Creation Complete in " & Duration & " minutes. " & iCount & " pages output.", vbOKOnly, "Create Book Paper Abstracts Web Pages"
0724 End If
0725End If
0726End 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 - August 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