Line-No. / Ref. | Code Line |
0001 | Public Sub CreateAbstractWebPages() |
0002 | Dim fsoTextFile As FileSystemObject |
0003 | Dim tsTextFile As TextStream |
0004 | Dim rsTableToRead As Recordset |
0005 | Dim rsTableToRead2 As Recordset |
0006 | Dim rsTableControl As Recordset |
0007 | Dim rsCitings As Recordset |
0008 | Dim rsNote As Recordset |
0009 | Dim strControlQuery As String |
0010 | Dim strLine As String |
0011 | Dim strText As String |
0012 | Dim strComment As String |
0013 | Dim strAbstract As String |
0014 | Dim i As Integer |
0015 | Dim x As Long |
0016 | Dim StartTime As Date |
0017 | Dim RunStartTime As Date |
0018 | Dim Duration As Double |
0019 | Dim Response As String |
0020 | Dim strMessage As String |
0021 | Dim Total_Run As Single |
0022 | Dim Run_Type As String |
0023 | Dim All_Done As Boolean |
0024 | Dim RunDate As Date |
0025 | Dim strAuthor As String |
0026 | Dim NoteID As Integer |
0027 | Dim SubDirectory As String |
0028 | Dim iCount As Long |
0029 | Dim strLine1 As String |
0030 | Dim Link_Count As Integer |
0031 | Dim Link_1 As String |
0032 | Dim Link_2 As String |
0033 | Dim Link_3 As String |
0034 | Dim Link_4 As String |
0035 | Dim Link_4_Saved As String |
0036 | Dim Link_5 As String |
0037 | Dim Link_6 As String |
0038 | Dim Link_Authors As String |
0039 | Dim strTable As String |
0040 | Dim strQuery As String |
0041 | Dim strNote_Date As String |
0042 | Dim sw As StopWatch |
0043 | Dim sw2 As StopWatch |
0044 | 'Test_Flag = True |
0045 | If Test_Flag = True Then |
0046 | Set sw = New StopWatch |
0047 | Set sw2 = New StopWatch |
0048 | End If |
0049 | iCount = 0 |
0050 | Set fsoTextFile = New FileSystemObject |
0051 | NotePaperLinksDB_Open = "Closed" |
0052 | Cross_Reference_Table_Open = False |
0053 | Set rsCross_Reference_Table = Nothing |
0054 | Total_Run = 0 |
0055 | If automatic_processing = "Yes" Then |
0056 | Run_Type = "Regen" |
0057 | Response = vbYes |
0058 | GoTo Automatic |
0059 | End If |
0060 | Response = MsgBox("Do you want to regenerate pages for changed Abstracts only?", vbYesNoCancel) |
0061 | If Response = vbYes Then |
0062 | Response = MsgBox("Do you want to include pages with embedded Notes?", vbYesNo + vbDefaultButton2) |
0063 | If Response = vbYes Then |
0064 | Response = MsgBox("Do you want to include pages with embedded Temp Notes only?", vbYesNo + vbDefaultButton1) |
0065 | If Response = vbYes Then |
0066 | strControlQuery = "Abstracts_Changed_List_Plus+TempNotes" |
0067 | Else |
0068 | strControlQuery = "Abstracts_Changed_List_Plus+Notes" |
0069 | Response = vbYes |
0070 | End If |
0071 | Else |
0072 | strControlQuery = "Abstracts_Changed_List" |
0073 | Response = vbYes |
0074 | End If |
0075 | Run_Type = "Changed" |
0076 | Else |
0077 | Run_Type = "Regen" |
0078 | If Response = vbNo Then |
0079 | Response = MsgBox("Do you want to regenerate Abstract pages for Papers with IDs in particular ranges?", vbYesNoCancel) |
0080 | If Response = vbYes Then |
0081 | Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM Paper_Abstract_Ranges WHERE [Select?] = True ORDER BY ID_Start;") |
0082 | If Not rsTableToRead.EOF Then |
0083 | rsTableToRead.MoveFirst |
0084 | strMessage = "Run for the following range" & IIf(rsTableToRead.RecordCount > 1, "s", "") & "?" & Chr(10) & Chr(10) |
0085 | Do While Not rsTableToRead.EOF |
0086 | 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) |
0087 | Total_Run = Total_Run + Nz(rsTableToRead.Fields(5)) |
0088 | rsTableToRead.MoveNext |
0089 | Loop |
0090 | strMessage = strMessage & "Total = " & Round(Total_Run, 0) & "m." & Chr(10) & Chr(10) |
0091 | Else |
0092 | DoCmd.OpenTable ("Paper_Abstract_Ranges") |
0093 | MsgBox ("No Ranges selected. Update the Paper_Abstract_Ranges Table.") |
0094 | End |
0095 | End If |
0096 | Total_Run = 0 |
0097 | Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM Paper_Abstract_Ranges WHERE [Select?] = False ORDER BY ID_Start;") |
0098 | If Not rsTableToRead.EOF Then |
0099 | strMessage = strMessage & "Not selected:- " & Chr(10) & Chr(10) |
0100 | rsTableToRead.MoveFirst |
0101 | Do While Not rsTableToRead.EOF |
0102 | 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) |
0103 | Total_Run = Total_Run + rsTableToRead.Fields(5) |
0104 | rsTableToRead.MoveNext |
0105 | Loop |
0106 | strMessage = strMessage & "Total o/s = " & Round(Total_Run, 0) & "m." & Chr(10) & Chr(10) |
0107 | End If |
0108 | Response = MsgBox(strMessage, vbYesNo) |
0109 | If Response = vbNo Then |
0110 | DoCmd.OpenTable ("Paper_Abstract_Ranges") |
0111 | MsgBox ("Update the Paper_Abstract_Ranges Table.") |
0112 | End |
0113 | End If |
0114 | End If |
0115 | End If |
0116 | End If |
0117 | Automatic: |
0118 | If Response <> vbYes Then |
0119 | MsgBox ("Try again!") |
0120 | Exit Sub |
0121 | End If |
0122 | RunStartTime = Now() |
0123 | StartTime = Now() |
0124 | OK = Convert_Webrefs("Paper", "Full") |
0125 | If Run_Type = "Changed" Then |
0126 | Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery) |
0127 | If rsTableToRead.EOF Then |
0128 | MsgBox ("No changed abstracts!") |
0129 | Exit Sub |
0130 | End If |
0131 | Else |
0132 | Set rsTableToRead2 = CurrentDb.OpenRecordset("SELECT * FROM Paper_Abstract_Ranges WHERE [Select?] = True ORDER BY ID_Start;") |
0133 | If rsTableToRead2.EOF Then |
0134 | All_Done = True |
0135 | Else |
0136 | All_Done = False |
0137 | rsTableToRead2.MoveFirst |
0138 | End If |
0139 | End If |
0140 | All_Done = False |
0141 | 'Output Abstract Pages |
0142 | Do Until All_Done = True |
0143 | If Run_Type = "Changed" Then |
0144 | All_Done = True |
0145 | Else |
0146 | 'Generate records list |
0147 | strControlQuery = "SELECT * FROM Abstracts_List WHERE (ID >= " & rsTableToRead2.Fields(1) & " AND ID <= " & rsTableToRead2.Fields(2) & ") ORDER BY ID;" |
0148 | Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery) |
0149 | If Not rsTableToRead.EOF Then |
0150 | rsTableToRead.MoveFirst |
0151 | End If |
0152 | End If |
0153 | 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;" |
0154 | Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery) |
0155 | If Not rsTableToRead.EOF Then |
0156 | rsTableToRead.MoveFirst |
0157 | End If |
0158 | Do While Not rsTableToRead.EOF |
0159 | If Test_Flag = True Then |
0160 | sw.StartTimer |
0161 | End If |
0162 | Clear_Colour_Usage |
0163 | strFolder = TheoWebsiteRoot & "\Abstracts\Abstract_" & Right(Str(Int(rsTableToRead.Fields(0) / 1000) + 1000000), 2) & "\" |
0164 | strFileName = "Abstract_" & rsTableToRead.Fields(0) & ".htm" |
0165 | Set tsTextFile = fsoTextFile.CreateTextFile(strFolder & strFileName, True, True) |
0166 | rsTableControl.MoveFirst |
0167 | OK = Zap_Cross_References("P", rsTableToRead.Fields(0), 0) |
0168 | 'NameRef = 0 |
0169 | Do While Not rsTableControl.EOF |
0170 | strLine = rsTableControl.Fields(0) & "" |
0171 | OK = Replace_Timestamp(strLine) |
0172 | x = InStr(1, strLine, "**HEAD_TITLE**") |
0173 | If x > 0 Then |
0174 | strLine = Left(strLine, x - 1) & rsTableToRead.Fields(1) & " - " & rsTableToRead.Fields(2) & " (Theo Todman's Book Collection - Paper Abstracts) " & Mid(strLine, x + 14, Len(strLine)) |
0175 | End If |
0176 | x = InStr(1, strLine, "**Author**") |
0177 | If x > 0 Then |
0178 | strAuthor = rsTableToRead.Fields(1) |
0179 | OK = Author_Reference_String(strAuthor, 2) |
0180 | strLine = Left(strLine, x - 1) & strAuthor & Mid(strLine, x + 10, Len(strLine)) |
0181 | End If |
0182 | x = InStr(1, strLine, "**Title**") |
0183 | If x > 0 Then |
0184 | strLine = Left(strLine, x - 1) & "" & rsTableToRead.Fields(2) & "" & Mid(strLine, x + 9, Len(strLine)) |
0185 | End If |
0186 | x = InStr(1, strLine, "**Source**") |
0187 | If x > 0 Then |
0188 | strLine = Left(strLine, x - 1) & "Source: " & rsTableToRead.Fields(5) & Mid(strLine, x + 10, Len(strLine)) |
0189 | End If |
0190 | x = InStr(1, strLine, "**LINK**") |
0191 | If x > 0 Then |
0192 | Link_Count = 0 |
0193 | Link_1 = "" |
0194 | Link_2 = "" |
0195 | Link_3 = "" |
0196 | Link_4 = "" |
0197 | Link_5 = "" |
0198 | Link_6 = "" |
0199 | Link_Authors = "" |
0200 | Link_1 = "Paper Statistics" |
0201 | Link_Count = Link_Count + 1 |
0202 | 'Output Book, Paper & Notes citing links |
0203 | If Test_Flag = True Then |
0204 | sw2.StartTimer |
0205 | End If |
0206 | strControlQuery = "SELECT Paper_Citings_List_New.* FROM Paper_Citings_List_New WHERE Paper_Citings_List_New.Paper_ID = " & rsTableToRead.Fields(0) & ";" |
0207 | Set rsCitings = CurrentDb.OpenRecordset(strControlQuery) |
0208 | If Not rsCitings.EOF Then |
0209 | rsCitings.MoveFirst |
0210 | Set rsCitings = Nothing |
0211 | Link_2 = "Books / Papers Citing this Paper" |
0212 | Link_Count = Link_Count + 1 |
0213 | End If |
0214 | If Test_Flag = True Then |
0215 | Debug.Print Now(); strFileName; sw2.EndTimer; "Milliseconds"; " Paper_Citings" |
0216 | sw2.StartTimer |
0217 | End If |
0218 | strControlQuery = "SELECT Note_Paper_Links.* FROM Note_Paper_Links WHERE Note_Paper_Links.Paper = " & rsTableToRead.Fields(0) & " AND Note_Paper_Links.Origin = ""Note"";" |
0219 | Set rsCitings = CurrentDb.OpenRecordset(strControlQuery) |
0220 | If Not rsCitings.EOF Then |
0221 | rsCitings.MoveFirst |
0222 | Link_3 = "Notes Citing this Paper" |
0223 | Link_Count = Link_Count + 1 |
0224 | Set rsCitings = Nothing |
0225 | End If |
0226 | If Test_Flag = True Then |
0227 | Debug.Print Now(); strFileName; sw2.EndTimer; "Milliseconds"; " Paper_Note_Counts" |
0228 | End If |
0229 | 'Add Author Citings |
0230 | If Test_Flag = True Then |
0231 | sw2.StartTimer |
0232 | End If |
0233 | 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;" |
0234 | Set rsCitings = CurrentDb.OpenRecordset(strControlQuery) |
0235 | If Not rsCitings.EOF Then |
0236 | rsCitings.MoveFirst |
0237 | Link_Authors = "
Authors Citing this Paper: " & rsCitings.Fields(0) & "" |
0238 | rsCitings.MoveNext |
0239 | Do While Not rsCitings.EOF |
0240 | strLine1 = strLine1 & ", " & rsCitings.Fields(0) & "" |
0241 | Link_Authors = Link_Authors & ", " & rsCitings.Fields(0) & "" |
0242 | rsCitings.MoveNext |
0243 | Loop |
0244 | Link_Authors = Link_Authors & "" |
0245 | Set rsCitings = Nothing |
0246 | End If |
0247 | If Test_Flag = True Then |
0248 | Debug.Print Now(); strFileName; sw2.EndTimer; "Milliseconds"; " Authors Citing this Paper" |
0249 | End If |
0250 | If rsTableToRead.Fields(6) & "" <> "" Then |
0251 | NoteID = rsTableToRead.Fields(6) |
0252 | strQuery = "SELECT Note_Groups.Note_Group FROM Notes INNER JOIN Note_Groups ON Notes.Note_Group = Note_Groups.ID WHERE (((Notes.ID)=" & NoteID & "));" |
0253 | Set rsNote = CurrentDb.OpenRecordset(strQuery) |
0254 | SubDirectory = Find_New_Directory(NoteID) |
0255 | SubDirectory = SubDirectory & "/Notes_" |
0256 | If rsNote.Fields(0) = "Supervisions" Then |
0257 | SubDirectory = "../../Secure_Jen/Notes_" & SubDirectory |
0258 | Else |
0259 | SubDirectory = "../../Notes/Notes_" & SubDirectory |
0260 | End If |
0261 | Link_4_Saved = "" |
0262 | Link_4 = Link_4_Saved & "Link to Latest Write-Up Note" |
0263 | Link_Count = Link_Count + 1 |
0264 | Else |
0265 | NoteID = 0 |
0266 | End If |
0267 | If InStr(rsTableToRead.Fields(3), "|Colour_2|") > 0 Then |
0268 | If Len(rsTableToRead.Fields(3)) > 1000 Then |
0269 | 'Advance warning for citation-text |
0270 | Link_5 = "Colour-Conventions" |
0271 | Link_Count = Link_Count + 1 |
0272 | End If |
0273 | SubDirectory = Find_New_Directory(1025) |
0274 | SubDirectory = SubDirectory & "/Notes_" |
0275 | Link_6 = "Disclaimer" |
0276 | Link_Count = Link_Count + 1 |
0277 | End If |
0278 | strTable = ""
0279 | If Link_1 <> "" Then |
0280 | strTable = strTable & "" & Link_1 & " | " |
0281 | End If |
0282 | If Link_2 <> "" Then |
0283 | strTable = strTable & "" & Link_2 & " | " |
0284 | End If |
0285 | If Link_3 <> "" Then |
0286 | strTable = strTable & "" & Link_3 & " | " |
0287 | End If |
0288 | If Link_4 <> "" Then |
0289 | strTable = strTable & "" & Link_4 & " | " |
0290 | End If |
0291 | If Link_5 <> "" Then |
0292 | strTable = strTable & "" & Link_5 & " | " |
0293 | End If |
0294 | If Link_6 <> "" Then |
0295 | strTable = strTable & "" & Link_6 & " | " |
0296 | End If |
0297 | strTable = strTable & " | " |
0298 | strLine = Left(strLine, x - 1) & strTable & Link_Authors & Mid(strLine, x + 8, Len(strLine)) |
0299 | End If |
0300 | x = InStr(1, strLine, "**TEXT**") |
0301 | If x > 0 Then |
0302 | If Test_Flag = True Then |
0303 | sw2.StartTimer |
0304 | End If |
0305 | strText = "|Colour_1|" |
0306 | strAbstract = Trim(rsTableToRead.Fields(3) & "") |
0307 | strComment = Trim(rsTableToRead.Fields(4)) & "" |
0308 | If Len(strAbstract) > 0 Then |
0309 | If Len(strComment) > 3000 Then |
0310 | 'Concatenate Abstract & Comment - Comment is overflow from Abstract |
0311 | strAbstract = strAbstract & strComment |
0312 | strComment = "" |
0313 | End If |
0314 | 'Encode any unencoded references first - otherwise they never get encoded! |
0315 | strAbstract = ImageRef(strAbstract, "Abstract", "P", rsTableToRead.Fields(0), 0) |
0316 | strText = strText & strAbstract |
0317 | Else |
0318 | strAbstract = "" |
0319 | End If |
0320 | If strComment <> "" Then |
0321 | If Len(strComment) > 0 Then |
0322 | 'Encode any unencoded references first - otherwise they never get encoded! |
0323 | strComment = ImageRef(strComment, "Abstract", "P", rsTableToRead.Fields(0), 0) |
0324 | strText = strText & IIf(Len(strAbstract) > 0, " ", "") & "|Colour_1|Comment: " & IIf(Left(strComment, 1) = "|", "", "
") & strComment & " " |
0325 | End If |
0326 | End If |
0327 | 'Write out Write-up Note (if any) |
0328 | If NoteID > 0 Then |
0329 | strQuery = "SELECT Notes.ID, Notes.Item_Title, Notes.Item_Text, Notes.Last_Changed, Notes.[Private?] FROM Notes WHERE (((Notes.ID)=" & NoteID & "));" |
0330 | Set rsNote = CurrentDb.OpenRecordset(strQuery) |
0331 | If Not rsNote.EOF Then |
0332 | If rsNote.Fields(4) & "" = "No" Then |
0333 | strNote_Date = rsNote.Fields(3) & "" |
0334 | If strNote_Date <> "" Then |
0335 | strNote_Date = CDate(strNote_Date / 1000) |
0336 | Else |
0337 | strNote_Date = Now() |
0338 | End If |
0339 | strText = strText & "|Colour_1|
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 & ". |..|++ (as at " & strNote_Date & "): " & Link_4_Saved & rsNote.Fields(1) & "
" & ImageRef(rsNote.Fields(2), "Abstract", "P", rsTableToRead.Fields(0), 0) |
0340 | End If |
0341 | End If |
0342 | End If |
0343 | 'In-page Footnotes, Etc. |
0344 | OK = Reference_FootNotes("P", rsTableToRead.Fields(0), strText) |
0345 | strText = strText & "|Colour_1| " |
0346 | strLine = Left(strLine, x - 1) & strText & Mid(strLine, x + 8, Len(strLine)) |
0347 | strLine = Remove_Dummy_Ref(strLine) |
0348 | strLine = WebEncode(strLine) |
0349 | OK = Mark_Colours(strLine) |
0350 | OK = Reference_Files(strLine, "P", rsTableToRead.Fields(0), 0) 'Replace the PDF Files References by hyperlinks |
0351 | OK = Reference_Notes(strLine, "P", rsTableToRead.Fields(0), 0, 2, "Abstract_Direct", "Paper", rsTableToRead.Fields(0)) 'Replace the Notes References by hyperlinks |
0352 | OK = Reference_Notes(strLine, "P", rsTableToRead.Fields(0), 0, 2, "Abstract", "Paper", rsTableToRead.Fields(0)) 'Replace the Notes References by hyperlinks |
0353 | OK = Reference_Papers(strLine, "P", rsTableToRead.Fields(0), 0) 'Replace the Papers References by hyperlinks |
0354 | OK = Reference_Author(strLine, "P", rsTableToRead.Fields(0), 0) 'Replace the Author References by hyperlinks |
0355 | OK = Reference_Note_Links(strLine, "P", rsTableToRead.Fields(0), 0) 'Replace the Note_Link References by hyperlinks |
0356 | OK = Reference_Books(strLine, "P", rsTableToRead.Fields(0), 0) 'Replace the Books References by hyperlinks |
0357 | OK = Reference_Webrefs(strLine, "P", rsTableToRead.Fields(0), 0) |
0358 | OK = Reference_Reference(strLine) |
0359 | strLine = ReplaceCode(strLine, Chr(13) & Chr(10), " ") |
0360 | 'Bullets |
0361 | strLine = NumberedBullets(strLine) |
0362 | strLine = Bullets(strLine) |
0363 | strLine = strLine & " Text Colour Conventions (see disclaimer) " |
0364 | For i = 0 To 19 |
0365 | If Colour_Table(i, 4) = "1" Then |
0366 | strLine = strLine & "" & Colour_Table(i, 2) & ": " & Colour_Table(i, 3) & "" |
0367 | End If |
0368 | Next i |
0369 | strLine = strLine & "" |
0370 | If Test_Flag = True Then |
0371 | Debug.Print Now(); strFileName; sw2.EndTimer; "Milliseconds"; " Process Text" |
0372 | End If |
0373 | End If |
0374 | 'Write out |
0375 | tsTextFile.WriteLine strLine |
0376 | rsTableControl.MoveNext |
0377 | Loop |
0378 | 'Log Referencing Changes |
0379 | If Test_Flag = True Then |
0380 | sw2.StartTimer |
0381 | End If |
0382 | If Full_Regen = False Then |
0383 | DoCmd.OpenQuery ("Cross_Reference_Changes_Deletions_Add") |
0384 | End If |
0385 | If Test_Flag = True Then |
0386 | Debug.Print Now(); strFileName; sw2.EndTimer; "Milliseconds"; " Cross_Reference_Changes_Deletions_Add" |
0387 | End If |
0388 | If Test_Flag = True Then |
0389 | sw2.StartTimer |
0390 | End If |
0391 | If Full_Regen = False Then |
0392 | DoCmd.OpenQuery ("Cross_Reference_Changes_Additions_Add") |
0393 | End If |
0394 | If Test_Flag = True Then |
0395 | Debug.Print Now(); strFileName; sw2.EndTimer; "Milliseconds"; " Cross_Reference_Changes_Additions_Add" |
0396 | End If |
0397 | 'Copy to Transfer |
0398 | If Test_Flag = True Then |
0399 | sw2.StartTimer |
0400 | End If |
0401 | OK = CopyToTransfer(strFolder, strFileName) |
0402 | If Test_Flag = True Then |
0403 | Debug.Print Now(); strFileName; sw2.EndTimer; "Milliseconds"; " CopyToTransfer" |
0404 | Debug.Print Now(); strFileName; sw.EndTimer; "Milliseconds" |
0405 | Stop |
0406 | End If |
0407 | iCount = iCount + 1 |
0408 | rsTableToRead.MoveNext |
0409 | Loop |
0410 | If Run_Type <> "Changed" Then |
0411 | 'Update the Paper_Abstract_Ranges Table |
0412 | Duration = Now() - StartTime |
0413 | Duration = Duration * 24 * 60 |
0414 | Duration = Round(Duration, 1) |
0415 | RunDate = Now() |
0416 | rsTableToRead2.Edit |
0417 | rsTableToRead2.Fields(4) = RunDate |
0418 | rsTableToRead2.Fields(5) = Duration |
0419 | rsTableToRead2.Update |
0420 | 'Read Next Range |
0421 | rsTableToRead2.MoveNext |
0422 | If rsTableToRead2.EOF Then |
0423 | All_Done = True |
0424 | End If |
0425 | StartTime = Now() |
0426 | End If |
0427 | Loop |
0428 | Set rsNotePaperLinksDB = Nothing |
0429 | Set rsTableToRead = Nothing |
0430 | Set rsTableToRead2 = Nothing |
0431 | Cross_Reference_Table_Open = False |
0432 | Set rsCross_Reference_Table = Nothing |
0433 | If Test_Flag = True Then |
0434 | Set sw = Nothing |
0435 | Set sw2 = Nothing |
0436 | End If |
0437 | DoCmd.OpenQuery ("Cross_Reference_Idempotency_Zap") |
0438 | If automatic_processing <> "Yes" Then |
0439 | Duration = Round((Now() - RunStartTime) * 24 * 60, 1) |
0440 | If Duration < 1 Then |
0441 | Duration = Round((Now() - RunStartTime) * 24 * 60 * 60) |
0442 | MsgBox Now() & ": Abstract Webpage Creation Complete in " & Duration & " seconds. " & iCount & " pages output.", vbOKOnly, "Create Paper Abstract Web Pages" |
0443 | Else |
0444 | MsgBox Now() & ": Abstract Webpage Creation Complete in " & Duration & " minutes. " & iCount & " pages output.", vbOKOnly, "Create Paper Abstract Web Pages" |
0445 | End If |
0446 | End If |
0447 | End Sub |
Line-No. / Ref. | Code Line |
0001 | Public Sub Webrefs_Update() |
0002 | Dim ie As InternetExplorer |
0003 | Dim rsTableControl As Recordset |
0004 | Dim i As Integer |
0005 | Dim j As Integer |
0006 | Dim k As Integer |
0007 | Dim Requested_URL |
0008 | Dim Returned_URL |
0009 | Dim start As Date |
0010 | Dim RunTime As Single |
0011 | Dim Running_Hours As Single |
0012 | Dim Issue As String |
0013 | Dim Defunct As Boolean |
0014 | Dim Update_Time As Double |
0015 | Dim Recent_Check_Days As Single |
0016 | Dim Recent_Check_Date As Single |
0017 | Dim Recent_Check As Date |
0018 | Dim Recent_Check_OK As Boolean |
0019 | Dim Last_Bounce As Date |
0020 | Dim Given_Up As Boolean |
0021 | Dim Uncheckable As Boolean |
0022 | Dim strQuery As String |
0023 | Dim sBounce As Single |
0024 | Dim max_Checks As Integer |
0025 | Dim Webrefs_Option As String |
0026 | Dim Option_Help As String |
0027 | Dim Issue_Check As String |
0028 | Dim YouTube_Check_Sent As String |
0029 | Dim YouTube_Check_Returned As String |
0030 | Dim Debug_Print As String |
0031 | Dim Returned_URL_Saved As String |
0032 | Dim Forced_Bounce As Boolean |
0033 | Dim strMessage As String |
0034 | Dim z As Integer |
0035 | Dim Check_Text As String |
0036 | Dim Check_404 As Boolean |
0037 | Dim Start_Time As Double |
0038 | Dim TagNames(100) As String |
0039 | Dim iTags As Integer |
0040 | 'Note: this Sub checks all recorded URLs in my website against the Web, and records the results |
0041 | 'Adjust the parameters below if needs-be ... |
0042 | Recent_Check_Days = 10 |
0043 | Recent_Check_Date = Now() - Recent_Check_Days |
0044 | Recent_Check = Now() - Recent_Check_Days 'Parameter - Check gap in days |
0045 | RunTime = 5 'Parameter - run time in hours |
0046 | sBounce = 5 'IE Bounce time in minutes |
0047 | max_Checks = 20 'In seconds I tried 5 minutes, but most previous time-outs seemed OK after 10 seconds |
0048 | Option_Help = "Parameters are:- " & Chr$(10) & "... Check after " & Recent_Check_Days & " days" |
0049 | Option_Help = Option_Help & Chr$(10) & "... Max run-time = " & RunTime & " hours" |
0050 | Option_Help = Option_Help & Chr$(10) & "... Bounce IE after " & sBounce & " minutes" |
0051 | Option_Help = Option_Help & Chr$(10) & "... Max checks = " & max_Checks |
0052 | Option_Help = Option_Help & Chr$(10) & "Choose an Option:-" |
0053 | Option_Help = Option_Help & Chr$(10) & "1. Run Full Check" |
0054 | Option_Help = Option_Help & Chr$(10) & "2. Run Check for New Links since last run" |
0055 | Option_Help = Option_Help & Chr$(10) & "3. Run for Time-outs when last checked" |
0056 | Webrefs_Option = InputBox(Option_Help, "Enter an integer Spider Option", 1) |
0057 | If Len(Webrefs_Option) = 0 Then |
0058 | End |
0059 | End If |
0060 | If Webrefs_Option < "1" Or Webrefs_Option > "3" Then |
0061 | MsgBox ("Choose an Option between 1 and 3") |
0062 | End |
0063 | End If |
0064 | Select Case Webrefs_Option |
0065 | Case 1 |
0066 | 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;" |
0067 | Case 2 |
0068 | strQuery = "SELECT * FROM Webrefs_Table WHERE (((Webrefs_Table.[Defunct?]) = False) And (([Date_Last_Checked] & """") = """")) ORDER BY Webrefs_Table.ID;" |
0069 | Case 3 |
0070 | strQuery = "SELECT * FROM Webrefs_Table WHERE (((Webrefs_Table.[Defunct?]) = False) And ((Webrefs_Table.Issue) = ""Timeout"")) ORDER BY Webrefs_Table.ID;" |
0071 | Recent_Check_Days = 0.5 / 24 |
0072 | max_Checks = 60 |
0073 | Recent_Check = Now() - Recent_Check_Days 'Parameter - Check gap in days - reset for Timeouts |
0074 | MsgBox ("Recent check parameter reset to half an hour & max checks to 60 - 1 minute - for Timeout-checker") |
0075 | Case Else |
0076 | End |
0077 | End Select |
0078 | Start_Time = Now() |
0079 | Set rsTableControl = CurrentDb.OpenRecordset(strQuery) |
0080 | If rsTableControl.EOF Then |
0081 | MsgBox "Nothing to do!" |
0082 | End |
0083 | Else |
0084 | DoEvents |
0085 | rsTableControl.MoveLast |
0086 | DoEvents |
0087 | End If |
0088 | strMessage = "References yet to check = " & rsTableControl.RecordCount |
0089 | Debug.Print Now() & " - "; strMessage |
0090 | MsgBox (strMessage) |
0091 | start = Now() |
0092 | Debug.Print Now() & " - "; "Webrefs_Update Started" |
0093 | Debug.Print Now() & " - "; "Webrefs_Update: " & strMessage |
0094 | strMessage = "Last References to check = " & rsTableControl.Fields(0) |
0095 | rsTableControl.MoveFirst |
0096 | strMessage = "First References to check = " & rsTableControl.Fields(0) & "; " & strMessage |
0097 | Debug.Print Now() & " - "; "Webrefs_Update: " & strMessage |
0098 | 'Open Internet Explorer in memory, and go to website |
0099 | Set ie = New InternetExplorer |
0100 | 'ie.Visible = False |
0101 | Last_Bounce = start |
0102 | Returned_URL_Saved = "zzz" |
0103 | Forced_Bounce = False |
0104 | z = 1 |
0105 | Do While Not rsTableControl.EOF |
0106 | 'Bounce IE every sBounce minutes |
0107 | If ((Now() - Last_Bounce) * 24 * 60 > sBounce) Or Forced_Bounce = True Then |
0108 | DoEvents |
0109 | ie.Quit |
0110 | Set ie = Nothing |
0111 | Set ie = New InternetExplorer |
0112 | 'ie.Visible = False |
0113 | Last_Bounce = Now() |
0114 | If Forced_Bounce = True Then |
0115 | strMessage = "Forced Bounce: " |
0116 | Forced_Bounce = False |
0117 | Else |
0118 | strMessage = "Regular Bounce: " |
0119 | End If |
0120 | Debug.Print Now() & " - " & strMessage & "IE Bounced at " & Last_Bounce & " - Count = " & z & ". Id=" & rsTableControl.Fields(0) |
0121 | End If |
0122 | Uncheckable = False |
0123 | 'Check if updated recently |
0124 | Recent_Check_OK = True |
0125 | If rsTableControl.Fields(4) > Recent_Check Then |
0126 | Recent_Check_OK = False |
0127 | End If |
0128 | Requested_URL = rsTableControl.Fields(1) |
0129 | 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 .... |
0130 | Uncheckable = True |
0131 | Recent_Check_OK = False |
0132 | Issue = "File Type Uncheckable" |
0133 | End If |
0134 | Update_Time = Now() |
0135 | Given_Up = False |
0136 | If Recent_Check_OK = True Then |
0137 | Resume_Here: |
0138 | Defunct = False |
0139 | Issue = "" |
0140 | On Error GoTo Err_Fix |
0141 | ie.Navigate Requested_URL |
0142 | Update_Time = Now() |
0143 | 'Wait until IE is done loading page |
0144 | i = 1 |
0145 | Returned_URL = "" |
0146 | If Err.Number <= 0 Then |
0147 | Do While ((ie.ReadyState < READYSTATE_COMPLETE) Or (Returned_URL = "")) And (Given_Up = False) |
0148 | DoEvents |
0149 | If ie.LocationURL & "" <> Returned_URL_Saved Then |
0150 | Returned_URL = ie.LocationURL |
0151 | End If |
0152 | i = i + 1 |
0153 | If i > max_Checks Then |
0154 | Given_Up = True |
0155 | Issue = "Timeout" |
0156 | Forced_Bounce = True |
0157 | End If |
0158 | WaitFor (1) 'Wait 1 second, then check again |
0159 | If Err.Number > 0 Then |
0160 | GoTo Err_Fix |
0161 | End If |
0162 | Loop |
0163 | Else |
0164 | GoTo Err_Fix |
0165 | End If |
0166 | If Given_Up = False Then |
0167 | 'Stick a test in here! This is mostly for future use .. |
0168 | For k = 1 To 100 |
0169 | TagNames(i) = "" |
0170 | Next k |
0171 | iTags = 0 |
0172 | On Error Resume Next 'Seems to work OK most of the time ... if it fails on the next line, "Object doesn't support this property or method" try terminating, compact & repair, and re-start. It's probably a recovery problem of some sort which I can't be bothered to resolve |
0173 | iTags = ie.Document.GetElementsByTagName("*").Length |
0174 | Err.Clear |
0175 | If InStr(Requested_URL, ".pdf") > 0 Then |
0176 | If iTags > 0 Then |
0177 | 'If it really were a .pdf, iTags would be 0, so ... |
0178 | Issue = "PDF Not Found" |
0179 | End If |
0180 | End If |
0181 | If iTags > 100 Then |
0182 | iTags = 100 |
0183 | End If |
0184 | If iTags > 0 Then |
0185 | 'Debug.Print iTags |
0186 | For k = 1 To iTags |
0187 | TagNames(i) = ie.Document.GetElementsByTagName("*")(i).TagName |
0188 | 'Debug.Print TagNames(i) |
0189 | Next k |
0190 | End If |
0191 | 'Proceed ... |
0192 | Returned_URL = "" |
0193 | Returned_URL = ie.LocationURL |
0194 | If Requested_URL = Returned_URL Then |
0195 | If InStr(Requested_URL, ".pdf") = 0 Then |
0196 | On Error Resume Next 'Didn't work ... |
0197 | Returned_URL = ie.Document.Url 'Some documents don't support this ... if so, comment out, step over, and uncomment ready for the next page |
0198 | Err.Clear |
0199 | On Error GoTo Err_Fix |
0200 | End If |
0201 | End If |
0202 | Returned_URL_Saved = Returned_URL |
0203 | If (Requested_URL <> Returned_URL) Then |
0204 | If (Replace(Returned_URL, "https", "http") = Requested_URL) And (Issue <> "PDF Not Found") Then |
0205 | Issue = "URL Secured" |
0206 | Else |
0207 | If ((Requested_URL & "/" = Returned_URL) Or (Requested_URL = Returned_URL & "/")) And (Issue <> "PDF Not Found") Then |
0208 | Issue = "URL with trailing slash" |
0209 | Else |
0210 | If InStr(Returned_URL, "http://www.webaddresshelp.bt.com") > 0 And (Issue <> "PDF Not Found") Then |
0211 | Issue = "URL Not found" |
0212 | Defunct = True |
0213 | Forced_Bounce = True |
0214 | Else |
0215 | If (Left(Returned_URL, Len("http://web.demo.barefruit.co.uk/")) = "http://web.demo.barefruit.co.uk/") And (Issue <> "PDF Not Found") Then |
0216 | Issue = "URL Not Found" |
0217 | Defunct = True |
0218 | Forced_Bounce = True |
0219 | Else |
0220 | If Right(Returned_URL, 4) <> ".pdf" Then |
0221 | On Error Resume Next 'Didn't work ... |
0222 | Check_Text = "" |
0223 | If ie.Document.GetElementsByTagName("title").Length > 0 Then |
0224 | Check_Text = ie.Document.GetElementsByTagName("title")(0).innerHtml |
0225 | End If |
0226 | If ie.Document.GetElementsByTagName("h1").Length > 0 Then |
0227 | Check_Text = Check_Text & ie.Document.GetElementsByTagName("h1")(0).innerHtml |
0228 | End If |
0229 | 'Probably could add other elements above ... ? |
0230 | If InStr(Check_Text, "404") > 0 Then |
0231 | If Issue <> "PDF Not Found" Then |
0232 | Issue = "Page Not Found" |
0233 | End If |
0234 | Defunct = True |
0235 | Else |
0236 | If InStr(Check_Text, "403") > 0 Then |
0237 | Issue = "Access Denied" |
0238 | Defunct = True |
0239 | End If |
0240 | End If |
0241 | If Issue = "" Then |
0242 | Issue = "URL Differs" |
0243 | End If |
0244 | Err.Clear |
0245 | On Error GoTo Err_Fix |
0246 | Else |
0247 | Issue = "PDF Not Found" |
0248 | End If |
0249 | End If |
0250 | End If |
0251 | End If |
0252 | End If |
0253 | End If |
0254 | If Issue = "" Then |
0255 | 'Check Aeon or Psyche "page not found" ... |
0256 | 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 |
0257 | Check_404 = False |
0258 | For j = 0 To ie.Document.GetElementsByTagName("p").Length - 1 |
0259 | Check_Text = ie.Document.GetElementsByTagName("p")(j).innerHtml |
0260 | If InStr(Check_Text, "(404)") > 0 Then |
0261 | Check_404 = True |
0262 | j = 30 |
0263 | End If |
0264 | Next j |
0265 | If Check_404 = True Then |
0266 | Issue = "Page Not Found" |
0267 | Defunct = True |
0268 | End If |
0269 | End If |
0270 | End If |
0271 | If Issue = "" Then |
0272 | 'Check Wikipedia "page not found" ... |
0273 | If InStr(Requested_URL, "https://en.wikipedia.org/wiki/") > 0 Then |
0274 | Check_404 = False |
0275 | For j = 0 To ie.Document.GetElementsByTagName("BODY").Length - 1 |
0276 | Check_Text = ie.Document.GetElementsByTagName("BODY")(j).innerHtml |
0277 | If InStr(Check_Text, "Wikipedia does not have an article with this exact name") > 0 Then |
0278 | Check_404 = True |
0279 | j = 30 |
0280 | End If |
0281 | Next j |
0282 | If Check_404 = True Then |
0283 | Issue = "Page Not Found" |
0284 | Defunct = True |
0285 | End If |
0286 | End If |
0287 | End If |
0288 | If Issue = "" Then |
0289 | If Right(Returned_URL, 4) <> ".pdf" Then |
0290 | On Error Resume Next 'Didn't work ... |
0291 | Check_Text = "" |
0292 | If ie.Document.GetElementsByTagName("title").Length > 0 Then |
0293 | Check_Text = ie.Document.GetElementsByTagName("title")(0).innerHtml |
0294 | End If |
0295 | If InStr(Check_Text, "404") > 0 Then |
0296 | Issue = "Page Not Found" |
0297 | Defunct = True |
0298 | Else |
0299 | If ie.Document.GetElementsByTagName("h1").Length > 0 Then |
0300 | Check_Text = ie.Document.GetElementsByTagName("h1")(0).innerHtml |
0301 | End If |
0302 | If InStr(Check_Text, "404") > 0 Then |
0303 | Issue = "Page Not Found" |
0304 | Defunct = True |
0305 | End If |
0306 | End If |
0307 | Err.Clear |
0308 | On Error GoTo Err_Fix |
0309 | End If |
0310 | End If |
0311 | End If |
0312 | If Issue = "URL Differs" Then |
0313 | If InStr(Requested_URL, "youtube") > 0 Then |
0314 | 'Check for YouTube time issues |
0315 | j = InStr(Requested_URL, "&t=") |
0316 | If j > 0 Then |
0317 | YouTube_Check_Sent = Left(Requested_URL, j - 1) |
0318 | Else |
0319 | YouTube_Check_Sent = Requested_URL |
0320 | End If |
0321 | j = InStr(Returned_URL, "&t=") |
0322 | If j > 0 Then |
0323 | YouTube_Check_Returned = Left(Requested_URL, j - 1) |
0324 | Else |
0325 | YouTube_Check_Returned = Requested_URL |
0326 | End If |
0327 | If YouTube_Check_Sent = YouTube_Check_Returned Then |
0328 | Issue = "" |
0329 | Else |
0330 | Forced_Bounce = True |
0331 | End If |
0332 | Else |
0333 | Forced_Bounce = True |
0334 | End If |
0335 | If InStr(Returned_URL, "res://ieframe.dll") > 0 Then |
0336 | Debug.Print Now() & " - Count = " & z & ". " & "Id=" & rsTableControl.Fields(0) & ". Returned_URL: "; Returned_URL |
0337 | Issue = "URL Not found" |
0338 | Returned_URL = "" |
0339 | End If |
0340 | End If |
0341 | If Issue = "URL Not Found" Then |
0342 | Defunct = True |
0343 | Issue_Check = Right(Requested_URL, 6) |
0344 | If (InStr(Issue_Check, ".htm") > 0) Or (InStr(Issue_Check, ".html") > 0) Or (InStr(Issue_Check, ".shtm") > 0) Or (Right(Issue_Check, 1) = "/") Then |
0345 | Issue = "Page Not Found" |
0346 | Else |
0347 | If InStr(Issue_Check, ".") > 0 Then |
0348 | Issue = "Document Not Found" |
0349 | Else |
0350 | Issue = "Page Not Found" |
0351 | End If |
0352 | End If |
0353 | End If |
0354 | rsTableControl.Edit |
0355 | rsTableControl.Fields(4) = Now() |
0356 | If Issue = "URL Differs" Then |
0357 | rsTableControl.Fields(5) = Left(Returned_URL, 255) |
0358 | Else |
0359 | rsTableControl.Fields(5) = "" |
0360 | End If |
0361 | rsTableControl.Fields(6) = Issue |
0362 | rsTableControl.Fields(7) = i |
0363 | Update_Time = (Now() - Update_Time) * 24 * 60 * 60 |
0364 | rsTableControl.Fields(8) = Update_Time |
0365 | rsTableControl.Fields(9) = Defunct |
0366 | rsTableControl.Update |
0367 | If Issue <> "" Then |
0368 | Debug_Print = " Issue = " & Issue |
0369 | Else |
0370 | Debug_Print = "" |
0371 | End If |
0372 | Debug_Print = Now() & " - Count = " & z & "." & Debug_Print & " Id=" & rsTableControl.Fields(0) & ", Tries = " & i & " Requested_URL = " & Requested_URL |
0373 | z = z + 1 |
0374 | If Issue = "URL Differs" Then |
0375 | Debug_Print = Debug_Print & " Returned_URL = " & Returned_URL |
0376 | End If |
0377 | If Issue <> "" Then |
0378 | Debug.Print Debug_Print |
0379 | End If |
0380 | End If |
0381 | rsTableControl.MoveNext |
0382 | Running_Hours = (Now() - start) * 24 |
0383 | If Running_Hours > RunTime Then |
0384 | Stop |
0385 | start = Now() |
0386 | End If |
0387 | Loop |
0388 | ie.Quit |
0389 | Set ie = Nothing |
0390 | Start_Time = Round((Now() - Start_Time) * 24 * 60, 1) |
0391 | Debug_Print = Now() & " - Webrefs_Update Completed in " & Start_Time & " minutes." |
0392 | Debug.Print Debug_Print |
0393 | MsgBox "Webrefs Checker Completed at " & Now() & " in " & Start_Time & " minutes." |
0394 | Exit Sub |
0395 | Err_Fix: |
0396 | Debug.Print Now() & " - Id=" & rsTableControl.Fields(0) & " " & Err.Description |
0397 | DoEvents |
0398 | Err.Clear |
0399 | Set ie = Nothing |
0400 | Set ie = New InternetExplorer |
0401 | 'ie.Visible = False |
0402 | Last_Bounce = Now() |
0403 | Forced_Bounce = False |
0404 | Debug.Print Now() & " - "; "Error Bounce: IE Bounced at " & Last_Bounce |
0405 | GoTo Resume_Here |
0406 | End Sub |