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 6 (3 items)

CreateAbstractWebPagesCreateModulesWebpageWebrefs_Update.

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

Go to top of page




Source Code of: CreateAbstractWebPages
Procedure Type: Public Sub
Module: General_Subroutines
Lines of Code: 443
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub CreateAbstractWebPages()
0002Dim fsoTextFile As FileSystemObject
0003Dim tsTextFile As TextStream
0004Dim rsTableToRead As Recordset
0005Dim rsTableToRead2 As Recordset
0006Dim rsTableControl As Recordset
0007Dim rsCitings As Recordset
0008Dim rsNote As Recordset
0009Dim strControlQuery As String
0010Dim strLine As String
0011Dim strText As String
0012Dim strComment As String
0013Dim strAbstract As String
0014Dim i As Integer
0015Dim x As Long
0016Dim StartTime As Date
0017Dim RunStartTime As Date
0018Dim Duration As Double
0019Dim Response As String
0020Dim strMessage As String
0021Dim Total_Run As Single
0022Dim Run_Type As String
0023Dim All_Done As Boolean
0024Dim RunDate As Date
0025Dim strAuthor As String
0026Dim NoteID As Integer
0027Dim SubDirectory As String
0028Dim iCount As Long
0029Dim strLine1 As String
0030Dim Link_Count As Integer
0031Dim Link_1 As String
0032Dim Link_2 As String
0033Dim Link_3 As String
0034Dim Link_4 As String
0035Dim Link_5 As String
0036Dim Link_6 As String
0037Dim Link_Authors As String
0038Dim strTable As String
0039Dim strQuery As String
0040Dim strNote_Date As String
0041Dim sw As StopWatch
0042Dim sw2 As StopWatch
0043'Test_Flag = True
0044If Test_Flag = True Then
0045 Set sw = New StopWatch
0046 Set sw2 = New StopWatch
0047End If
0048iCount = 0
0049Set fsoTextFile = New FileSystemObject
0050NotePaperLinksDB_Open = "Closed"
0051Cross_Reference_Table_Open = False
0052Set rsCross_Reference_Table = Nothing
0053Total_Run = 0
0054If automatic_processing = "Yes" Then
0055 Run_Type = "Regen"
0056 Response = vbYes
0057 GoTo Automatic
0058End If
0059Response = MsgBox("Do you want to regenerate pages for changed Abstracts only?", vbYesNoCancel)
0060If Response = vbYes Then
0061 Response = MsgBox("Do you want to include pages with embedded Notes?", vbYesNo + vbDefaultButton2)
0062 If Response = vbYes Then
0063 Response = MsgBox("Do you want to include pages with embedded Temp Notes only?", vbYesNo + vbDefaultButton1)
0064 If Response = vbYes Then
0065 strControlQuery = "Abstracts_Changed_List_Plus+TempNotes"
0066 Else
0067 strControlQuery = "Abstracts_Changed_List_Plus+Notes"
0068 Response = vbYes
0069 End If
0070 Else
0071 strControlQuery = "Abstracts_Changed_List"
0072 Response = vbYes
0073 End If
0074 Run_Type = "Changed"
0075Else
0076 Run_Type = "Regen"
0077 If Response = vbNo Then
0078 Response = MsgBox("Do you want to regenerate Abstract pages for Papers with IDs in particular ranges?", vbYesNoCancel)
0079 If Response = vbYes Then
0080 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM Paper_Abstract_Ranges WHERE [Select?] = True ORDER BY ID_Start;")
0081 If Not rsTableToRead.EOF Then
0082 rsTableToRead.MoveFirst
0083 strMessage = "Run for the following range" & IIf(rsTableToRead.RecordCount > 1, "s", "") & "?" & Chr(10) & Chr(10)
0084 Do While Not rsTableToRead.EOF
0085 strMessage = strMessage & rsTableToRead.Fields(0) & ": " & rsTableToRead.Fields(1) & "-" & rsTableToRead.Fields(2) & ": " & Round(rsTableToRead.Fields(5), 0) & "m (" & Round(rsTableToRead.Fields(4), 0) & ", " & Round((Now() - Round(rsTableToRead.Fields(4))), 0) & "d)" & Chr(10)
0086 Total_Run = Total_Run + Nz(rsTableToRead.Fields(5))
0087 rsTableToRead.MoveNext
0088 Loop
0089 strMessage = strMessage & "Total = " & Round(Total_Run, 0) & "m." & Chr(10) & Chr(10)
0090 Else
0091 DoCmd.OpenTable ("Paper_Abstract_Ranges")
0092 MsgBox ("No Ranges selected. Update the Paper_Abstract_Ranges Table.")
0093 End
0094 End If
0095 Total_Run = 0
0096 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM Paper_Abstract_Ranges WHERE [Select?] = False ORDER BY ID_Start;")
0097 If Not rsTableToRead.EOF Then
0098 strMessage = strMessage & "Not selected:- " & Chr(10) & Chr(10)
0099 rsTableToRead.MoveFirst
0100 Do While Not rsTableToRead.EOF
0101 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)
0102 Total_Run = Total_Run + rsTableToRead.Fields(5)
0103 rsTableToRead.MoveNext
0104 Loop
0105 strMessage = strMessage & "Total o/s = " & Round(Total_Run, 0) & "m." & Chr(10) & Chr(10)
0106 End If
0107 Response = MsgBox(strMessage, vbYesNo)
0108 If Response = vbNo Then
0109 DoCmd.OpenTable ("Paper_Abstract_Ranges")
0110 MsgBox ("Update the Paper_Abstract_Ranges Table.")
0111 End
0112 End If
0113 End If
0114 End If
0115End If
0116Automatic:
0117If Response <> vbYes Then
0118 MsgBox ("Try again!")
0119 Exit Sub
0120End If
0121RunStartTime = Now()
0122StartTime = Now()
0123 OK = Convert_Webrefs("Paper", "Full")
0124If Run_Type = "Changed" Then
0125 Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0126 If rsTableToRead.EOF Then
0127 MsgBox ("No changed abstracts!")
0128 Exit Sub
0129 End If
0130Else
0131 Set rsTableToRead2 = CurrentDb.OpenRecordset("SELECT * FROM Paper_Abstract_Ranges WHERE [Select?] = True ORDER BY ID_Start;")
0132 If rsTableToRead2.EOF Then
0133 All_Done = True
0134 Else
0135 All_Done = False
0136 rsTableToRead2.MoveFirst
0137 End If
0138End If
0139All_Done = False
0140'Output Abstract Pages
0141Do Until All_Done = True
0142 If Run_Type = "Changed" Then
0143 All_Done = True
0144 Else
0145 'Generate records list
0146 strControlQuery = "SELECT * FROM Abstracts_List WHERE (ID >= " & rsTableToRead2.Fields(1) & " AND ID <= " & rsTableToRead2.Fields(2) & ") ORDER BY ID;"
0147 Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0148 If Not rsTableToRead.EOF Then
0149 rsTableToRead.MoveFirst
0150 End If
0151 End If
0152 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = ""Abstract"") And ((Website_Control.Section) = ""Text"")) ORDER BY Website_Control.Line;"
0153 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0154 If Not rsTableToRead.EOF Then
0155 rsTableToRead.MoveFirst
0156 End If
0157 Do While Not rsTableToRead.EOF
0158 If Test_Flag = True Then
0159 sw.StartTimer
0160 End If
0161 Clear_Colour_Usage
0162 strFolder = "C:\Theo's Files\Websites\Theo's Website\Abstracts\Abstract_" & Right(Str(Int(rsTableToRead.Fields(0) / 1000) + 1000000), 2) & "\"
0163 strFileName = "Abstract_" & rsTableToRead.Fields(0) & ".htm"
0164 Set tsTextFile = fsoTextFile.CreateTextFile(strFolder & strFileName, True, True)
0165 rsTableControl.MoveFirst
0166 OK = Zap_Cross_References("P", rsTableToRead.Fields(0), 0)
0167 NameRef = 0
0168 Do While Not rsTableControl.EOF
0169 strLine = rsTableControl.Fields(0) & ""
0170 OK = Replace_Timestamp(strLine)
0171 x = InStr(1, strLine, "**HEAD_TITLE**")
0172 If x > 0 Then
0173 strLine = Left(strLine, x - 1) & rsTableToRead.Fields(1) & " - " & rsTableToRead.Fields(2) & " (Theo Todman's Book Collection - Paper Abstracts) " & Mid(strLine, x + 14, Len(strLine))
0174 End If
0175 x = InStr(1, strLine, "**Author**")
0176 If x > 0 Then
0177 strAuthor = rsTableToRead.Fields(1)
0178 OK = Author_Reference_String(strAuthor, 2)
0179 strLine = Left(strLine, x - 1) & strAuthor & Mid(strLine, x + 10, Len(strLine))
0180 End If
0181 x = InStr(1, strLine, "**Title**")
0182 If x > 0 Then
0183 strLine = Left(strLine, x - 1) & "<A HREF = """ & "../../PaperSummaries/PaperSummary_" & Right(Str(Int(rsTableToRead.Fields(0) / 1000) + 1000000), 2) & "/" & "PaperSummary_" & rsTableToRead.Fields(0) & ".htm" & """>" & rsTableToRead.Fields(2) & "</A>" & Mid(strLine, x + 9, Len(strLine))
0184 End If
0185 x = InStr(1, strLine, "**Source**")
0186 If x > 0 Then
0187 strLine = Left(strLine, x - 1) & "Source: " & rsTableToRead.Fields(5) & Mid(strLine, x + 10, Len(strLine))
0188 End If
0189 x = InStr(1, strLine, "**LINK**")
0190 If x > 0 Then
0191 Link_Count = 0
0192 Link_1 = ""
0193 Link_2 = ""
0194 Link_3 = ""
0195 Link_4 = ""
0196 Link_5 = ""
0197 Link_6 = ""
0198 Link_Authors = ""
0199 Link_1 = "<A HREF = """ & "../../PaperSummaries/PaperSummary_" & Right(Str(Int(rsTableToRead.Fields(0) / 1000) + 1000000), 2) & "/" & "PaperSummary_" & rsTableToRead.Fields(0) & ".htm" & """>Paper Statistics</A>"
0200 Link_Count = Link_Count + 1
0201 'Output Book, Paper & Notes citing links
0202 If Test_Flag = True Then
0203 sw2.StartTimer
0204 End If
0205 strControlQuery = "SELECT Paper_Citings_List_New.* FROM Paper_Citings_List_New WHERE Paper_Citings_List_New.Paper_ID = " & rsTableToRead.Fields(0) & ";"
0206 Set rsCitings = CurrentDb.OpenRecordset(strControlQuery)
0207 If Not rsCitings.EOF Then
0208 rsCitings.MoveFirst
0209 Set rsCitings = Nothing
0210 Link_2 = "<A HREF = ""../../PaperSummaries/PaperSummary_" & Mid(rsTableToRead.Fields(0) + 1000000, 3, 2) & "/PaperCitings_" & rsTableToRead.Fields(0) & ".htm"">Books / Papers Citing this Paper</A>"
0211 Link_Count = Link_Count + 1
0212 End If
0213 If Test_Flag = True Then
0214 Debug.Print Now(); strFileName; sw2.EndTimer; "Milliseconds"; " Paper_Citings"
0215 sw2.StartTimer
0216 End If
0217 strControlQuery = "SELECT Paper_Note_Counts.* FROM Paper_Note_Counts WHERE Paper_Note_Counts.Paper = " & rsTableToRead.Fields(0) & ";"
0218 Set rsCitings = CurrentDb.OpenRecordset(strControlQuery)
0219 If Not rsCitings.EOF Then
0220 rsCitings.MoveFirst
0221 Link_3 = "<A HREF = ""../../PaperSummaries/PaperSummary_" & Mid(rsTableToRead.Fields(0) + 1000000, 3, 2) & "/PapersToNotes_" & rsTableToRead.Fields(0) & ".htm"">Notes Citing this Paper</A>"
0222 Link_Count = Link_Count + 1
0223 Set rsCitings = Nothing
0224 End If
0225 If Test_Flag = True Then
0226 Debug.Print Now(); strFileName; sw2.EndTimer; "Milliseconds"; " Paper_Note_Counts"
0227 End If
0228 'Add Author Citings
0229 If Test_Flag = True Then
0230 sw2.StartTimer
0231 End If
0232 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) = ""P"")) ORDER BY Authors.Author_Name;"
0233 Set rsCitings = CurrentDb.OpenRecordset(strControlQuery)
0234 If Not rsCitings.EOF Then
0235 rsCitings.MoveFirst
0236 Link_Authors = "<hr><p><B>Authors Citing this Paper</B>: <A HREF = ""../../Authors/" & Left(rsCitings.Fields(0), 1) & "/Author_" & rsCitings.Fields(0) & ".htm"">" & rsCitings.Fields(0) & "</A>"
0237 rsCitings.MoveNext
0238 Do While Not rsCitings.EOF
0239 strLine1 = strLine1 & ", <A HREF = ""../../Authors/" & Left(rsCitings.Fields(0), 1) & "/Author_" & rsCitings.Fields(0) & ".htm"">" & rsCitings.Fields(0) & "</A>"
0240 Link_Authors = Link_Authors & ", <A HREF = ""../../Authors/" & Left(rsCitings.Fields(0), 1) & "/Author_" & rsCitings.Fields(0) & ".htm"">" & rsCitings.Fields(0) & "</A>"
0241 rsCitings.MoveNext
0242 Loop
0243 Link_Authors = Link_Authors & "</p>"
0244 Set rsCitings = Nothing
0245 End If
0246 If Test_Flag = True Then
0247 Debug.Print Now(); strFileName; sw2.EndTimer; "Milliseconds"; " Authors Citing this Paper"
0248 End If
0249 If rsTableToRead.Fields(6) & "" <> "" Then
0250 NoteID = rsTableToRead.Fields(6)
0251 strQuery = "SELECT Note_Groups.Note_Group FROM Notes INNER JOIN Note_Groups ON Notes.Note_Group = Note_Groups.ID WHERE (((Notes.ID)=" & NoteID & "));"
0252 Set rsNote = CurrentDb.OpenRecordset(strQuery)
0253 SubDirectory = Find_New_Directory(NoteID)
0254 SubDirectory = SubDirectory & "/Notes_"
0255 If rsNote.Fields(0) = "Supervisions" Then
0256 SubDirectory = "../../Secure_Jen/Notes_" & SubDirectory
0257 Else
0258 SubDirectory = "../../Notes/Notes_" & SubDirectory
0259 End If
0260 Link_4 = "<A HREF = """ & SubDirectory & rsTableToRead.Fields(6).Value & ".htm"">Link to Latest Write-Up Note</A>"
0261 Link_Count = Link_Count + 1
0262 Else
0263 NoteID = 0
0264 End If
0265 If InStr(rsTableToRead.Fields(3), "|Colour_2|") > 0 Then
0266 If Len(rsTableToRead.Fields(3)) > 1000 Then
0267 'Advance warning for citation-text
0268 Link_5 = "<A HREF=""#ColourConventions"">Colour-Conventions</a>"
0269 Link_Count = Link_Count + 1
0270 End If
0271 SubDirectory = Find_New_Directory(1025)
0272 SubDirectory = SubDirectory & "/Notes_"
0273 Link_6 = "<A HREF = ""../../Notes/Notes_" & SubDirectory & "1025.htm"">Disclaimer</A>"
0274 Link_Count = Link_Count + 1
0275 End If
0276 strTable = "<CENTER><TABLE class = ""Bridge"" WIDTH=" & Link_Count * 200 & "><tr>"
0277 If Link_1 <> "" Then
0278 strTable = strTable & "<td>" & Link_1 & "</td>"
0279 End If
0280 If Link_2 <> "" Then
0281 strTable = strTable & "<td>" & Link_2 & "</td>"
0282 End If
0283 If Link_3 <> "" Then
0284 strTable = strTable & "<td>" & Link_3 & "</td>"
0285 End If
0286 If Link_4 <> "" Then
0287 strTable = strTable & "<td>" & Link_4 & "</td>"
0288 End If
0289 If Link_5 <> "" Then
0290 strTable = strTable & "<td>" & Link_5 & "</td>"
0291 End If
0292 If Link_6 <> "" Then
0293 strTable = strTable & "<td>" & Link_6 & "</td>"
0294 End If
0295 strTable = strTable & "</tr></TABLE></CENTER>"
0296 strLine = Left(strLine, x - 1) & strTable & Link_Authors & Mid(strLine, x + 8, Len(strLine))
0297 End If
0298 x = InStr(1, strLine, "**TEXT**")
0299 If x > 0 Then
0300 If Test_Flag = True Then
0301 sw2.StartTimer
0302 End If
0303 strText = "|Colour_1|"
0304 strAbstract = Trim(rsTableToRead.Fields(3) & "")
0305 strComment = Trim(rsTableToRead.Fields(4)) & ""
0306 If Len(strAbstract) > 0 Then
0307 If Len(strComment) > 5000 Then
0308 'Concatenate Abstract & Comment - Comment is overflow from Abstract
0309 strAbstract = strAbstract & strComment
0310 strComment = ""
0311 End If
0312 'Encode any unencoded references first - otherwise they never get encoded!
0313 strAbstract = ImageRef(strAbstract, "Abstract", "P", rsTableToRead.Fields(0), 0)
0314 strText = strText & strAbstract
0315 Else
0316 strAbstract = ""
0317 End If
0318 If strComment <> "" Then
0319 If Len(strComment) > 0 Then
0320 'Encode any unencoded references first - otherwise they never get encoded!
0321 strComment = ImageRef(strComment, "Abstract", "P", rsTableToRead.Fields(0), 0)
0322 strText = strText & IIf(Len(strAbstract) > 0, "<hr>", "") & "|Colour_1|<B>Comment: </B>" & IIf(Left(strComment, 1) = "|", "", "<BR><BR>") & strComment & "<BR>"
0323 End If
0324 End If
0325 'Write out Write-up Note (if any)
0326 If NoteID > 0 Then
0327 strQuery = "SELECT Notes.ID, Notes.Item_Title, Notes.Item_Text, Notes.Last_Changed, Notes.[Private?] FROM Notes WHERE (((Notes.ID)=" & NoteID & "));"
0328 Set rsNote = CurrentDb.OpenRecordset(strQuery)
0329 If Not rsNote.EOF Then
0330 If rsNote.Fields(4) & "" = "No" Then
0331 strNote_Date = rsNote.Fields(3) & ""
0332 If strNote_Date <> "" Then
0333 strNote_Date = CDate(strNote_Date / 1000)
0334 Else
0335 strNote_Date = Now()
0336 End If
0337 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)
0338 End If
0339 End If
0340 End If
0341 'In-page Footnotes, Etc.
0342 OK = Reference_FootNotes("P", rsTableToRead.Fields(0), strText)
0343 strText = strText & "|Colour_1|<HR>"
0344 strLine = Left(strLine, x - 1) & strText & Mid(strLine, x + 8, Len(strLine))
0345 strLine = Remove_Dummy_Ref(strLine)
0346 strLine = WebEncode(strLine)
0347 OK = Mark_Colours(strLine)
0348 OK = Reference_Notes(strLine, "P", rsTableToRead.Fields(0), 0, 2, "Abstract_Direct", "Paper", rsTableToRead.Fields(0)) 'Replace the Notes References by hyperlinks
0349 OK = Reference_Notes(strLine, "P", rsTableToRead.Fields(0), 0, 2, "Abstract", "Paper", rsTableToRead.Fields(0)) 'Replace the Notes References by hyperlinks
0350 OK = Reference_Papers(strLine, "P", rsTableToRead.Fields(0), 0) 'Replace the Papers References by hyperlinks
0351 OK = Reference_Author(strLine, "P", rsTableToRead.Fields(0), 0) 'Replace the Author References by hyperlinks
0352 OK = Reference_Note_Links(strLine, "P", rsTableToRead.Fields(0), 0) 'Replace the Note_Link References by hyperlinks
0353 OK = Reference_Books(strLine, "P", rsTableToRead.Fields(0), 0) 'Replace the Books References by hyperlinks
0354 OK = Reference_Webrefs(strLine, "P", rsTableToRead.Fields(0), 0)
0355 strLine = ReplaceCode(strLine, Chr(13) & Chr(10), "<BR>")
0356 'Bullets
0357 strLine = NumberedBullets(strLine)
0358 strLine = Bullets(strLine)
0359 strLine = strLine & "<a name=""ColourConventions""></a><p><b>Text Colour Conventions (see <A HREF=""../../Notes/Notes_10/Notes_1025.htm"">disclaimer</a>)</b></p><OL TYPE=""1"">"
0360 For i = 0 To 19
0361 If Colour_Table(i, 4) = "1" Then
0362 strLine = strLine & "<LI><FONT COLOR = """ & Colour_Table(i, 1) & """>" & Colour_Table(i, 2) & "</FONT>: " & Colour_Table(i, 3) & "</li>"
0363 End If
0364 Next i
0365 strLine = strLine & "</OL>"
0366 If Test_Flag = True Then
0367 Debug.Print Now(); strFileName; sw2.EndTimer; "Milliseconds"; " Process Text"
0368 End If
0369 End If
0370 'Write out
0371 tsTextFile.WriteLine strLine
0372 rsTableControl.MoveNext
0373 Loop
0374 'Log Referencing Changes
0375 If Test_Flag = True Then
0376 sw2.StartTimer
0377 End If
0378 If Full_Regen = False Then
0379 DoCmd.OpenQuery ("Cross_Reference_Changes_Deletions_Add")
0380 End If
0381 If Test_Flag = True Then
0382 Debug.Print Now(); strFileName; sw2.EndTimer; "Milliseconds"; " Cross_Reference_Changes_Deletions_Add"
0383 End If
0384 If Test_Flag = True Then
0385 sw2.StartTimer
0386 End If
0387 If Full_Regen = False Then
0388 DoCmd.OpenQuery ("Cross_Reference_Changes_Additions_Add")
0389 End If
0390 If Test_Flag = True Then
0391 Debug.Print Now(); strFileName; sw2.EndTimer; "Milliseconds"; " Cross_Reference_Changes_Additions_Add"
0392 End If
0393 'Copy to Transfer
0394 If Test_Flag = True Then
0395 sw2.StartTimer
0396 End If
0397 OK = CopyToTransfer(strFolder, strFileName)
0398 If Test_Flag = True Then
0399 Debug.Print Now(); strFileName; sw2.EndTimer; "Milliseconds"; " CopyToTransfer"
0400 Debug.Print Now(); strFileName; sw.EndTimer; "Milliseconds"
0401 Stop
0402 End If
0403 iCount = iCount + 1
0404 rsTableToRead.MoveNext
0405 Loop
0406 If Run_Type <> "Changed" Then
0407 'Update the Paper_Abstract_Ranges Table
0408 Duration = Now() - StartTime
0409 Duration = Duration * 24 * 60
0410 Duration = Round(Duration, 1)
0411 RunDate = Now()
0412 rsTableToRead2.Edit
0413 rsTableToRead2.Fields(4) = RunDate
0414 rsTableToRead2.Fields(5) = Duration
0415 rsTableToRead2.Update
0416 'Read Next Range
0417 rsTableToRead2.MoveNext
0418 If rsTableToRead2.EOF Then
0419 All_Done = True
0420 End If
0421 StartTime = Now()
0422 End If
0423Loop
0424Set rsNotePaperLinksDB = Nothing
0425Set rsTableToRead = Nothing
0426Set rsTableToRead2 = Nothing
0427Cross_Reference_Table_Open = False
0428Set rsCross_Reference_Table = Nothing
0429If Test_Flag = True Then
0430 Set sw = Nothing
0431 Set sw2 = Nothing
0432End If
0433 DoCmd.OpenQuery ("Cross_Reference_Idempotency_Zap")
0434If automatic_processing <> "Yes" Then
0435 Duration = Round((Now() - RunStartTime) * 24 * 60, 1)
0436 If Duration < 1 Then
0437 Duration = Round((Now() - RunStartTime) * 24 * 60 * 60)
0438 MsgBox Now() & ": Abstract Webpage Creation Complete in " & Duration & " seconds. " & iCount & " pages output.", vbOKOnly, "Create Paper Abstract Web Pages"
0439 Else
0440 MsgBox Now() & ": Abstract Webpage Creation Complete in " & Duration & " minutes. " & iCount & " pages output.", vbOKOnly, "Create Paper Abstract Web Pages"
0441 End If
0442End If
0443End Sub

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



Source Code of: CreateModulesWebpage
Procedure Type: Public Sub
Module: Documentation
Lines of Code: 60
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub CreateModulesWebpage()
0002Dim rsTableControl As Recordset
0003Dim strControlQuery As String
0004Dim strLine As String
0005Dim iTableColumns As Integer
0006Dim strFileSuffix As String
0007Dim Procedure_Type As String
0008Dim Heading As String
0009Dim rsTableToRead As Recordset
0010Dim Module As String
0011'Create the Documentation_Code_Modules File
0012'Read the data
0013 strDataQuery = "SELECT Code_Table.Module FROM Code_Table GROUP BY Code_Table.Module ORDER BY Code_Table.Module;"
0014Set rsTableToRead = CurrentDb.OpenRecordset(strDataQuery)
0015rsTableToRead.MoveFirst
0016'Create File
0017strOutputFileShort = SubSystem & "Documentation_Code_Modules"
0018Set tsTextFile = fsoTextFile2.CreateTextFile(strOutputFolder & strOutputFileShort & ".htm", True, True)
0019'Create Page Header
0020 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;"
0021Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0022rsTableControl.MoveFirst
0023Do While Not rsTableControl.EOF
0024 strLine = rsTableControl.Fields(0) & ""
0025 tsTextFile.WriteLine strLine
0026 rsTableControl.MoveNext
0027Loop
0028'Create Main Jump Table
0029iTableColumns = 5
0030Procedure_Type = "Modules"
0031Heading = "Modules"
0032 OK = CreateDocumentationJumpTables(Procedure_Type, Heading, iTableColumns)
0033Do While Not rsTableToRead.EOF
0034 Module = rsTableToRead.Fields(0).Value
0035 'Create Module Jump Table
0036 iTableColumns = 5
0037 Procedure_Type = "Modules"
0038 Heading = "Module: " & Module
0039 OK = CreateDocumentationJumpTables(Procedure_Type, Heading, iTableColumns, Module)
0040 rsTableToRead.MoveNext
0041Loop
0042'Create link to main code jump-table
0043 strLine = "<A HREF=""" & SubSystem & "DocumentationControl.htm"">Link to VBA Code Control Page</A><br>"
0044tsTextFile.WriteLine strLine
0045'Finish File
0046'Page Footer
0047 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;"
0048Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0049rsTableControl.MoveFirst
0050Do While Not rsTableControl.EOF
0051 strLine = rsTableControl.Fields(0)
0052 OK = Replace_Timestamp(strLine)
0053 tsTextFile.WriteLine strLine
0054 rsTableControl.MoveNext
0055Loop
0056'Copy to Transfer
0057strFileSuffix = strOutputFileShort
0058 OK = CopyToTransfer(strFolder, strFileSuffix & ".htm")
0059Set tsTextFile = Nothing
0060End Sub

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



Source Code of: Webrefs_Update
Procedure Type: Public Sub
Module: Spider
Lines of Code: 361
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Webrefs_Update()
0002Dim ie As InternetExplorer
0003Dim rsTableControl As Recordset
0004Dim i As Integer
0005Dim j As Integer
0006Dim Requested_URL
0007Dim Returned_URL
0008Dim start As Date
0009Dim RunTime As Single
0010Dim Running_Hours As Single
0011Dim Issue As String
0012Dim Defunct As Boolean
0013Dim Update_Time As Double
0014Dim Recent_Check_Days As Single
0015Dim Recent_Check_Date As Single
0016Dim Recent_Check As Date
0017Dim Recent_Check_OK As Boolean
0018Dim Last_Bounce As Date
0019Dim Given_Up As Boolean
0020Dim Uncheckable As Boolean
0021Dim strQuery As String
0022Dim sBounce As Single
0023Dim max_Checks As Integer
0024Dim Webrefs_Option As String
0025Dim Option_Help As String
0026Dim Issue_Check As String
0027Dim YouTube_Check_Sent As String
0028Dim YouTube_Check_Returned As String
0029Dim Debug_Print As String
0030Dim Returned_URL_Saved As String
0031Dim Forced_Bounce As Boolean
0032Dim strMessage As String
0033Dim z As Integer
0034Dim Check_Text As String
0035Dim Check_404 As Boolean
0036Dim Start_Time As Double
0037'Note: this Sub checks all recorded URLs in my website against the Web, and records the results
0038'Adjust the parameters below if needs-be ...
0039Recent_Check_Days = 10
0040Recent_Check_Date = Now() - Recent_Check_Days
0041Recent_Check = Now() - Recent_Check_Days 'Parameter - Check gap in days
0042RunTime = 5 'Parameter - run time in hours
0043sBounce = 5 'IE Bounce time in minutes
0044max_Checks = 20 'In seconds I tried 5 minutes, but most previous time-outs seemed OK after 10 seconds
0045Option_Help = "Parameters are:- " & Chr$(10) & "... Check after " & Recent_Check_Days & " days"
0046Option_Help = Option_Help & Chr$(10) & "... Max run-time = " & RunTime & " hours"
0047Option_Help = Option_Help & Chr$(10) & "... Bounce IE after " & sBounce & " minutes"
0048Option_Help = Option_Help & Chr$(10) & "... Max checks = " & max_Checks
0049Option_Help = Option_Help & Chr$(10) & "Choose an Option:-"
0050Option_Help = Option_Help & Chr$(10) & "1. Run Full Check"
0051Option_Help = Option_Help & Chr$(10) & "2. Run Check for New Links since last run"
0052Option_Help = Option_Help & Chr$(10) & "3. Run for Time-outs when last checked"
0053Webrefs_Option = InputBox(Option_Help, "Enter an integer Spider Option", 1)
0054If Len(Webrefs_Option) = 0 Then
0055 End
0056End If
0057If Webrefs_Option < "1" Or Webrefs_Option > "3" Then
0058 MsgBox ("Choose an Option between 1 and 3")
0059 End
0060End If
0061Select Case Webrefs_Option
0062 Case 1
0063 strQuery = "SELECT * FROM Webrefs_Table WHERE (((Webrefs_Table.[Defunct?]) = False) And (([Date_Last_Checked] + 0) < " & Recent_Check_Date & ") And ((Webrefs_Table.Issue) <> ""Manual Check OK"")) Or (((Webrefs_Table.[Defunct?]) = False) And (([Date_Last_Checked] + 0) < " & Recent_Check_Date & ") And ((Webrefs_Table.Issue) Is Null)) ORDER BY Webrefs_Table.ID;"
0064 Case 2
0065 strQuery = "SELECT * FROM Webrefs_Table WHERE (((Webrefs_Table.[Defunct?]) = False) And (([Date_Last_Checked] & """") = """")) ORDER BY Webrefs_Table.ID;"
0066 Case 3
0067 strQuery = "SELECT * FROM Webrefs_Table WHERE (((Webrefs_Table.[Defunct?]) = False) And ((Webrefs_Table.Issue) = ""Timeout"")) ORDER BY Webrefs_Table.ID;"
0068 Recent_Check_Days = 0.5 / 24
0069 max_Checks = 60
0070 Recent_Check = Now() - Recent_Check_Days 'Parameter - Check gap in days - reset for Timeouts
0071 MsgBox ("Recent check parameter reset to half an hour & max checks to 60 - 1 minute - for Timeout-checker")
0072 Case Else
0073 End
0074End Select
0075Start_Time = Now()
0076Set rsTableControl = CurrentDb.OpenRecordset(strQuery)
0077If rsTableControl.EOF Then
0078 MsgBox "Nothing to do!"
0079 End
0080Else
0081 DoEvents
0082 rsTableControl.MoveLast
0083 DoEvents
0084End If
0085strMessage = "References yet to check = " & rsTableControl.RecordCount
0086Debug.Print Now() & " - "; strMessage
0087MsgBox (strMessage)
0088start = Now()
0089Debug.Print Now() & " - "; "Webrefs_Update Started"
0090Debug.Print Now() & " - "; "Webrefs_Update: " & strMessage
0091strMessage = "Last References to check = " & rsTableControl.Fields(0)
0092rsTableControl.MoveFirst
0093strMessage = "First References to check = " & rsTableControl.Fields(0) & "; " & strMessage
0094Debug.Print Now() & " - "; "Webrefs_Update: " & strMessage
0095'Open Internet Explorer in memory, and go to website
0096Set ie = New InternetExplorer
0097ie.Visible = False
0098Last_Bounce = start
0099Returned_URL_Saved = "zzz"
0100Forced_Bounce = False
0101z = 1
0102Do While Not rsTableControl.EOF
0103 'Bounce IE every sBounce minutes
0104 If ((Now() - Last_Bounce) * 24 * 60 > sBounce) Or Forced_Bounce = True Then
0105 DoEvents
0106 ie.Quit
0107 Set ie = Nothing
0108 Set ie = New InternetExplorer
0109 ie.Visible = False
0110 Last_Bounce = Now()
0111 If Forced_Bounce = True Then
0112 strMessage = "Forced Bounce: "
0113 Forced_Bounce = False
0114 Else
0115 strMessage = "Regular Bounce: "
0116 End If
0117 Debug.Print Now() & " - " & strMessage & "IE Bounced at " & Last_Bounce & " - Count = " & z & ". Id=" & rsTableControl.Fields(0)
0118 End If
0119 Uncheckable = False
0120 'Check if updated recently
0121 Recent_Check_OK = True
0122 If rsTableControl.Fields(4) > Recent_Check Then
0123 Recent_Check_OK = False
0124 End If
0125 Requested_URL = rsTableControl.Fields(1)
0126 If Right(Requested_URL, 4) = ".doc" Or Right(Requested_URL, 5) = ".docx" Or Right(Requested_URL, 4) = ".mp3" Or Right(Requested_URL, 4) = ".pps" Then 'Word or PowerPoint docs can't be saved automatically & mp3s loop ....
0127 Uncheckable = True
0128 Recent_Check_OK = False
0129 Issue = "File Type Uncheckable"
0130 End If
0131 Update_Time = Now()
0132 Given_Up = False
0133 If Recent_Check_OK = True Then
0134Resume_Here:
0135 Defunct = False
0136 Issue = ""
0137 On Error GoTo Err_Fix
0138 ie.Navigate Requested_URL
0139 Update_Time = Now()
0140 'Wait until IE is done loading page
0141 i = 1
0142 Returned_URL = ""
0143 If Err.Number = 0 Then
0144 Do While ((ie.ReadyState < READYSTATE_COMPLETE) Or (Returned_URL = "")) And (Given_Up = False)
0145 DoEvents
0146 If ie.LocationURL & "" <> Returned_URL_Saved Then
0147 Returned_URL = ie.LocationURL
0148 End If
0149 i = i + 1
0150 If i > max_Checks Then
0151 Given_Up = True
0152 Issue = "Timeout"
0153 Forced_Bounce = True
0154 End If
0155 WaitFor (1) 'Wait 1 second, then check again
0156 If Err.Number <> 0 Then
0157 GoTo Err_Fix
0158 End If
0159 Loop
0160 Else
0161 GoTo Err_Fix
0162 End If
0163 If Given_Up = False Then
0164 Returned_URL = ""
0165 Returned_URL = ie.LocationURL
0166 If Requested_URL = Returned_URL Then
0167 If InStr(Requested_URL, ".pdf") = 0 Then
0168 On Error Resume Next 'Didn't work ...
0169 Returned_URL = ie.Document.Url 'Some documents don't support this ... if so, comment out, step over, and uncomment ready for the next page
0170 Err.Clear
0171 On Error GoTo Err_Fix
0172 End If
0173 End If
0174 Returned_URL_Saved = Returned_URL
0175 If (Requested_URL <> Returned_URL) Then
0176 If Replace(Returned_URL, "https", "http") = Requested_URL Then
0177 Issue = "URL Secured"
0178 Else
0179 If (Requested_URL & "/" = Returned_URL) Or (Requested_URL = Returned_URL & "/") Then
0180 Issue = "URL with trailing slash"
0181 Else
0182 If InStr(Returned_URL, "http://www.webaddresshelp.bt.com") > 0 Then
0183 Issue = "URL Not found"
0184 Defunct = True
0185 Forced_Bounce = True
0186 Else
0187 If Left(Returned_URL, Len("http://web.demo.barefruit.co.uk/")) = "http://web.demo.barefruit.co.uk/" Then
0188 Issue = "URL Not Found"
0189 Defunct = True
0190 Forced_Bounce = True
0191 Else
0192 If Right(Returned_URL, 4) <> ".pdf" Then
0193 Issue = "URL Differs"
0194 On Error Resume Next 'Didn't work ...
0195 Check_Text = ""
0196 If ie.Document.GetElementsByTagName("title").Length > 0 Then
0197 Check_Text = ie.Document.GetElementsByTagName("title")(0).innerHtml
0198 End If
0199 If InStr(Check_Text, "404") > 0 Then
0200 Issue = "Page Not Found"
0201 Defunct = True
0202 Else
0203 If ie.Document.GetElementsByTagName("h1").Length > 0 Then
0204 Check_Text = ie.Document.GetElementsByTagName("h1")(0).innerHtml
0205 End If
0206 If InStr(Check_Text, "404") > 0 Then
0207 Issue = "Page Not Found"
0208 Defunct = True
0209 'Else
0210 ' If ie.Document.GetElementsByTagName("error").Length > 0 Then
0211 ' Issue = "Page Not Found"
0212 ' Defunct = True
0213 ' End If
0214 End If
0215 End If
0216 Err.Clear
0217 On Error GoTo Err_Fix
0218 Else
0219 Issue = "URL Differs"
0220 End If
0221 End If
0222 End If
0223 End If
0224 End If
0225 End If
0226 If Issue = "" Then
0227 'Check Aeon or Psyche "page not found" ...
0228 If (InStr(Requested_URL, "https://aeon.co/") > 0 And Len(Requested_URL) > Len("https://aeon.co/about/")) Or (InStr(Requested_URL, "https://psyche.co/") > 0 And Len(Requested_URL) > Len("https://psyche.co/about/")) Then
0229 Check_404 = False
0230 For j = 0 To ie.Document.GetElementsByTagName("p").Length - 1
0231 Check_Text = ie.Document.GetElementsByTagName("p")(j).innerHtml
0232 If InStr(Check_Text, "(404)") > 0 Then
0233 Check_404 = True
0234 j = 30
0235 End If
0236 Next j
0237 If Check_404 = True Then
0238 Issue = "Page Not Found"
0239 Defunct = True
0240 End If
0241 End If
0242 End If
0243 If Issue = "" Then
0244 If Right(Returned_URL, 4) <> ".pdf" Then
0245 On Error Resume Next 'Didn't work ...
0246 Check_Text = ""
0247 If ie.Document.GetElementsByTagName("title").Length > 0 Then
0248 Check_Text = ie.Document.GetElementsByTagName("title")(0).innerHtml
0249 End If
0250 If InStr(Check_Text, "404") > 0 Then
0251 Issue = "Page Not Found"
0252 Defunct = True
0253 Else
0254 If ie.Document.GetElementsByTagName("h1").Length > 0 Then
0255 Check_Text = ie.Document.GetElementsByTagName("h1")(0).innerHtml
0256 End If
0257 If InStr(Check_Text, "404") > 0 Then
0258 Issue = "Page Not Found"
0259 Defunct = True
0260 End If
0261 End If
0262 Err.Clear
0263 On Error GoTo Err_Fix
0264 End If
0265 End If
0266 End If
0267 If Issue = "URL Differs" Then
0268 If InStr(Requested_URL, "youtube") > 0 Then
0269 'Check for YouTube time issues
0270 j = InStr(Requested_URL, "&t=")
0271 If j > 0 Then
0272 YouTube_Check_Sent = Left(Requested_URL, j - 1)
0273 Else
0274 YouTube_Check_Sent = Requested_URL
0275 End If
0276 j = InStr(Returned_URL, "&t=")
0277 If j > 0 Then
0278 YouTube_Check_Returned = Left(Requested_URL, j - 1)
0279 Else
0280 YouTube_Check_Returned = Requested_URL
0281 End If
0282 If YouTube_Check_Sent = YouTube_Check_Returned Then
0283 Issue = ""
0284 Else
0285 Forced_Bounce = True
0286 End If
0287 Else
0288 Forced_Bounce = True
0289 End If
0290 If InStr(Returned_URL, "res://ieframe.dll") > 0 Then
0291 Debug.Print Now() & " - Count = " & z & ". " & "Id=" & rsTableControl.Fields(0) & ". Returned_URL: "; Returned_URL
0292 Issue = "URL Not found"
0293 Returned_URL = ""
0294 End If
0295 End If
0296 If Issue = "URL Not Found" Then
0297 Defunct = True
0298 Issue_Check = Right(Requested_URL, 6)
0299 If (InStr(Issue_Check, ".htm") > 0) Or (InStr(Issue_Check, ".html") > 0) Or (InStr(Issue_Check, ".shtm") > 0) Or (Right(Issue_Check, 1) = "/") Then
0300 Issue = "Page Not Found"
0301 Else
0302 If InStr(Issue_Check, ".") > 0 Then
0303 Issue = "Document Not Found"
0304 Else
0305 Issue = "Page Not Found"
0306 End If
0307 End If
0308 End If
0309 rsTableControl.Edit
0310 rsTableControl.Fields(4) = Now()
0311 If Issue = "URL Differs" Then
0312 rsTableControl.Fields(5) = Left(Returned_URL, 255)
0313 Else
0314 rsTableControl.Fields(5) = ""
0315 End If
0316 rsTableControl.Fields(6) = Issue
0317 rsTableControl.Fields(7) = i
0318 Update_Time = (Now() - Update_Time) * 24 * 60 * 60
0319 rsTableControl.Fields(8) = Update_Time
0320 rsTableControl.Fields(9) = Defunct
0321 rsTableControl.Update
0322 If Issue <> "" Then
0323 Debug_Print = " Issue = " & Issue
0324 Else
0325 Debug_Print = ""
0326 End If
0327 Debug_Print = Now() & " - Count = " & z & "." & Debug_Print & " Id=" & rsTableControl.Fields(0) & ", Tries = " & i & " Requested_URL = " & Requested_URL
0328 z = z + 1
0329 If Issue = "URL Differs" Then
0330 Debug_Print = Debug_Print & " Returned_URL = " & Returned_URL
0331 End If
0332 If Issue <> "" Then
0333 Debug.Print Debug_Print
0334 End If
0335 End If
0336 rsTableControl.MoveNext
0337 Running_Hours = (Now() - start) * 24
0338 If Running_Hours > RunTime Then
0339 Stop
0340 start = Now()
0341 End If
0342Loop
0343ie.Quit
0344Set ie = Nothing
0345Start_Time = Round((Now() - Start_Time) * 24 * 60, 1)
0346 Debug_Print = Now() & " - Webrefs_Update Completed in " & Start_Time & " minutes."
0347Debug.Print Debug_Print
0348MsgBox "Webrefs Checker Completed at " & Now() & " in " & Start_Time & " minutes."
0349Exit Sub
0350Err_Fix:
0351Debug.Print Now() & " - Id=" & rsTableControl.Fields(0) & " " & Err.Description
0352DoEvents
0353Err.Clear
0354Set ie = Nothing
0355Set ie = New InternetExplorer
0356ie.Visible = False
0357Last_Bounce = Now()
0358Forced_Bounce = False
0359Debug.Print Now() & " - "; "Error Bounce: IE Bounced at " & Last_Bounce
0360GoTo Resume_Here
0361End Sub

Procedures Calling This Procedure (Webrefs_Update) Procedures Called By This Procedure (Webrefs_Update) Tables / Queries / Fragments Directly Used By This Procedure (Webrefs_Update) 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