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 41 (7 items)

cmdRegenerateArchivedNoteRanges_ClickConvert_WebrefsGetPrecisLinkReference_Webrefs
Spider_Note_Remove_SectionSpider_Note_Reverse_BulletsSpider_WebLinks_Tester_Page_Gen.

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

Go to top of page



Source Code of: cmdRegenerateArchivedNoteRanges_Click
Procedure Type: Private Sub
Module: Form_Notes_Archive_Regen
Lines of Code: 124
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Private Sub cmdRegenerateArchivedNoteRanges_Click()
0002Dim rsTableControl As Recordset
0003Dim rsTableToRead As Recordset
0004Dim i As Integer
0005Dim Temp_Note_ID
0006Dim strMessage As String
0007Dim StartTime As Date
0008Dim RunStartTime As Date
0009Dim Duration As Double
0010Dim Response As String
0011Dim Total_Run As Single
0012Dim RunDate As Date
0013Dim NumberOfRows As Integer
0014Dim RowCount As Integer
0015Dim StopRows As Boolean
0016Dim Etc_Message As String
0017Dim ID_Start As Integer
0018Dim ID_End As Integer
0019i = 0
0020If MsgBox("Do you want to regenerate ranges of Archived Notes based on the Note_Archive_Regen_Ranges table?", vbYesNo) = vbYes Then
0021 Etc_Message = " ... Etc. " & Chr(10)
0022 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM Note_Archive_Regen_Ranges WHERE [Select?] = True ORDER BY ID_Start;")
0023 If Not rsTableToRead.EOF Then
0024 rsTableToRead.MoveFirst
0025 NumberOfRows = rsTableToRead.RecordCount
0026 RowCount = 0
0027 StopRows = False
0028 strMessage = "Run for the following range" & IIf(rsTableToRead.RecordCount > 1, "s", "") & "?" & Chr(10) & Chr(10)
0029 Do While Not rsTableToRead.EOF
0030 RowCount = RowCount + 1
0031 If RowCount < 15 Then
0032 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)
0033 Else
0034 If StopRows = False Then
0035 If NumberOfRows > 20 Then
0036 StopRows = True
0037 strMessage = strMessage & Etc_Message
0038 Else
0039 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)
0040 End If
0041 End If
0042 End If
0043 Total_Run = Total_Run + rsTableToRead.Fields(5)
0044 rsTableToRead.MoveNext
0045 Loop
0046 strMessage = strMessage & "Total time = " & Round(Total_Run, 0) & " mins." & Chr(10) & Chr(10)
0047 Else
0048 DoCmd.OpenTable ("Note_Archive_Regen_Ranges")
0049 MsgBox ("No Ranges selected. Update the Note_Archive_Regen_Ranges Table.")
0050 End
0051 End If
0052 Total_Run = 0
0053 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM Note_Archive_Regen_Ranges WHERE [Select?] = False ORDER BY ID_Start;")
0054 If Not rsTableToRead.EOF Then
0055 NumberOfRows = NumberOfRows + rsTableToRead.RecordCount
0056 strMessage = strMessage & "Not selected:- " & Chr(10) & Chr(10)
0057 rsTableToRead.MoveFirst
0058 Do While Not rsTableToRead.EOF
0059 RowCount = RowCount + 1
0060 If StopRows = False Then
0061 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)
0062 End If
0063 If RowCount > 18 Then
0064 If NumberOfRows > 20 Then
0065 StopRows = True
0066 strMessage = strMessage & Etc_Message
0067 Etc_Message = ""
0068 End If
0069 End If
0070 Total_Run = Total_Run + rsTableToRead.Fields(5)
0071 rsTableToRead.MoveNext
0072 Loop
0073 strMessage = strMessage & "Total time outstanding = " & Round(Total_Run, 0) & " mins." & Chr(10) & Chr(10)
0074 End If
0075 Response = MsgBox(strMessage, vbYesNo)
0076 If Response = vbNo Then
0077 DoCmd.OpenTable ("Note_Archive_Regen_Ranges")
0078 MsgBox ("Update the Note_Archive_Regen_Ranges Table.")
0079 End
0080 Else
0081 RunStartTime = Now()
0082 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM Note_Archive_Regen_Ranges WHERE [Select?] = True ORDER BY ID_Start;")
0083 If Not rsTableToRead.EOF Then
0084 rsTableToRead.MoveFirst
0085 Do While Not rsTableToRead.EOF
0086 StartTime = Now()
0087 ID_Start = rsTableToRead.Fields(1)
0088 ID_End = rsTableToRead.Fields(2)
0089 strQuery = "SELECT [ID], [Timestamp] FROM Notes_Archive WHERE [ID] >= " & ID_Start & " AND [ID] <= " & ID_End & " ORDER BY [ID], [Timestamp]; "
0090 Set rsTableControl = CurrentDb.OpenRecordset(strQuery)
0091 If Not rsTableControl.EOF Then
0092 rsTableControl.MoveFirst
0093 Do While Not rsTableControl.EOF
0094 Note_ID = rsTableControl.Fields(0)
0095 Note_Timestamp = rsTableControl.Fields(1)
0096 OK = OutputNotesWebPage_Archived(Note_ID, Note_Timestamp)
0097 i = i + 1
0098 rsTableControl.MoveNext
0099 Loop
0100 End If
0101 'Update the control table
0102 Duration = Now() - StartTime
0103 Duration = Duration * 24 * 60
0104 Duration = Round(Duration, 1)
0105 RunDate = Now()
0106 rsTableToRead.Edit
0107 rsTableToRead.Fields(4) = RunDate
0108 rsTableToRead.Fields(5) = Duration
0109 rsTableToRead.Update
0110 StartTime = Now()
0111 rsTableToRead.MoveNext
0112 Loop
0113 End If
0114 End If
0115End If
0116Duration = (Now() - RunStartTime) * 24 * 60
0117If Duration < 1 Then
0118 Duration = Round(Duration * 60)
0119 MsgBox Now() & ": Notes Archive Webpage Creation Complete in " & Duration & " seconds. " & i & " Pages output. ", vbOKOnly, "Create Notes Archive Web Pages"
0120Else
0121 Duration = Round(Duration, 2)
0122 MsgBox Now() & ": Notes Archive Webpage Creation Complete in " & Duration & " minutes. " & i & " Pages output. ", vbOKOnly, "Create Notes Archive Web Pages"
0123End If
0124End Sub

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


Source Code of: Convert_Webrefs
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 135
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Convert_Webrefs(RunType, Optional RunType2)
0002Dim start As Double
0003Dim Duration As Double
0004Dim rsTableToRead As Recordset
0005Dim rsMaintenance As Recordset
0006Dim strLine As String
0007Dim strLine_New As String
0008Dim i As Long
0009Dim j As Long
0010Dim All_Done As String
0011Dim strQuery As String
0012Dim Use_Maintainable_Objects As Boolean
0013i = 0
0014j = 0
0015If IsMissing(RunType2) Then
0016 Use_Maintainable_Objects = True
0017Else
0018 Use_Maintainable_Objects = False
0019End If
0020Err.Clear
0021On Error GoTo End_Of
0022start = Now()
0023If Use_Maintainable_Objects = True Then
0024 If RunType = "Note_Archive" Then
0025 DoCmd.RunSQL ("DELETE * FROM Maintainable_Archived_Objects;")
0026 DoCmd.OpenQuery ("Maintainable_Archived_Objects_GEN")
0027 Else
0028 DoCmd.RunSQL ("DELETE * FROM Maintainable_Objects;")
0029 DoCmd.OpenQuery ("Maintainable_Objects_GEN")
0030 End If
0031End If
0032Select Case RunType
0033 Case "Author"
0034 If Use_Maintainable_Objects = True Then
0035 strQuery = "SELECT Authors.Author_ID, Authors.Author_Narrative FROM Maintainable_Objects INNER JOIN Authors ON Maintainable_Objects.Object_ID = Authors.Author_ID WHERE (((Authors.Author_Narrative) Is Not Null) And ((Maintainable_Objects.Object_Type) = ""A"") And ((Maintainable_Objects.Other_Type) = ""W"")) ORDER BY Authors.Author_ID;"
0036 Else
0037 strQuery = "SELECT Authors.Author_ID, Authors.Author_Narrative FROM Authors WHERE (((Authors.Author_Narrative) Like ""*http*"")) OR (((Authors.Author_Narrative) Like ""*www*""));"
0038 End If
0039 Set rsTableToRead = CurrentDb.OpenRecordset(strQuery)
0040 Case "Book"
0041 If Use_Maintainable_Objects = True Then
0042 strQuery = "SELECT Books.ID1, Books.Comments FROM Books INNER JOIN Maintainable_Objects ON Books.ID1 = Maintainable_Objects.Object_ID WHERE (((Books.Comments) Is Not Null) AND ((Maintainable_Objects.Object_Type) = ""B"") And ((Maintainable_Objects.Other_Type) = ""W"")) ORDER BY Books.ID1;"
0043 Else
0044 strQuery = "SELECT Books.ID1, Books.Comments FROM Books WHERE (((Books.Comments) Like ""*http*"")) OR (((Books.Comments) Like ""*www*""));"
0045 End If
0046 Set rsTableToRead = CurrentDb.OpenRecordset(strQuery)
0047 'The above doesn't seem to work for Notes, so additionally select all "Temp" Notes
0048 Case "Note"
0049 If Use_Maintainable_Objects = True Then
0050 strQuery = "SELECT Notes.ID, Notes.Item_Text FROM Notes LEFT JOIN Maintainable_Objects ON Notes.ID = Maintainable_Objects.Object_ID WHERE (((Notes.Item_Text) Is Not Null) And ((Maintainable_Objects.Object_Type) = ""N"") And ((Maintainable_Objects.Other_Type) = ""W"")) Or (((Notes.Status) = ""Temp"")) ORDER BY Notes.ID;"
0051 Else
0052 strQuery = "SELECT Notes.ID, Notes.Item_Text FROM Notes WHERE (((Notes.Item_Text) Like ""*http*"")) OR (((Notes.Item_Text) Like ""*www*""));"
0053 End If
0054 Set rsTableToRead = CurrentDb.OpenRecordset(strQuery)
0055 Case "Note_Archive"
0056 If Use_Maintainable_Objects = True Then
0057 strQuery = "SELECT Notes_Archive.ID, Notes_Archive.Item_Text FROM Notes_Archive INNER JOIN Maintainable_Archived_Objects ON (Maintainable_Archived_Objects.Object_Timestamp = Notes_Archive.Timestamp) AND (Notes_Archive.ID = Maintainable_Archived_Objects.Object_ID) WHERE (((Notes_Archive.Item_Text) Is Not Null) And ((Maintainable_Archived_Objects.Object_Type) = ""N"") And ((Maintainable_Archived_Objects.Other_Type) = ""W"")) ORDER BY Notes_Archive.ID;"
0058 Else
0059 strQuery = "SELECT Notes_Archive.ID, Notes_Archive.Item_Text FROM Notes_Archive WHERE (((Notes_Archive.Item_Text) Like ""*http*"")) OR (((Notes_Archive.Item_Text) Like ""*www*""));"
0060 End If
0061 Set rsTableToRead = CurrentDb.OpenRecordset(strQuery)
0062 Case "Paper"
0063 If Use_Maintainable_Objects = True Then
0064 strQuery = "SELECT Papers.ID, Papers.Comments FROM Papers INNER JOIN Maintainable_Objects ON Papers.ID = Maintainable_Objects.Object_ID WHERE (((Papers.Comments) Is Not Null) AND ((Maintainable_Objects.Object_Type) = ""P"") And ((Maintainable_Objects.Other_Type) = ""W"")) ORDER BY Papers.ID;"
0065 Else
0066 strQuery = "SELECT Papers.ID, Papers.Comments FROM Papers WHERE (((Papers.Comments) Like ""*http*"")) OR (((Papers.Comments) Like ""*www*""));"
0067 End If
0068 Set rsTableToRead = CurrentDb.OpenRecordset(strQuery)
0069 Case Else
0070 MsgBox ("Dud type " & RunType & " in Convert_Webrefs")
0071End Select
0072If Not rsTableToRead.EOF Then
0073 rsTableToRead.MoveFirst
0074End If
0075All_Done = "No"
0076Do Until All_Done = "Yes"
0077 Do Until rsTableToRead.EOF
0078 i = i + 1
0079 strLine = rsTableToRead.Fields(1)
0080 strLine_New = WebEncode(strLine)
0081 If strLine_New <> strLine Then
0082 j = j + 1
0083 rsTableToRead.Edit
0084 rsTableToRead.Fields(1) = strLine_New
0085 rsTableToRead.Update
0086 End If
0087 rsTableToRead.MoveNext
0088 Loop
0089 If All_Done = "No" Then
0090 All_Done = "Half"
0091 Select Case RunType
0092 Case "Book"
0093 If Use_Maintainable_Objects = True Then
0094 strQuery = "SELECT Books.ID1, Books.Abstract FROM Books INNER JOIN Maintainable_Objects ON Books.ID1 = Maintainable_Objects.Object_ID WHERE (((Books.Abstract) Is Not Null) AND ((Maintainable_Objects.Object_Type) = ""B"") And ((Maintainable_Objects.Other_Type) = ""W"")) ORDER BY Books.ID1;"
0095 Else
0096 strQuery = "SELECT Books.ID1, Books.Abstract FROM Books WHERE (((Books.Abstract) Like ""*http*"")) OR (((Books.Abstract) Like ""*www*""));"
0097 End If
0098 Set rsTableToRead = CurrentDb.OpenRecordset(strQuery)
0099 Case "Paper"
0100 If Use_Maintainable_Objects = True Then
0101 strQuery = "SELECT Papers.ID, Papers.Abstract FROM Papers INNER JOIN Maintainable_Objects ON Papers.ID = Maintainable_Objects.Object_ID WHERE (((Papers.Abstract) Is Not Null) AND ((Maintainable_Objects.Object_Type) = ""P"") And ((Maintainable_Objects.Other_Type) = ""W"")) ORDER BY Papers.ID;"
0102 Else
0103 strQuery = "SELECT Papers.ID, Papers.Abstract FROM Papers WHERE (((Papers.Abstract) Like ""*http*"")) OR (((Papers.Abstract) Like ""*www*""));"
0104 End If
0105 Set rsTableToRead = CurrentDb.OpenRecordset(strQuery)
0106 Case Else
0107 All_Done = "Yes"
0108 End Select
0109 Else
0110 All_Done = "Yes"
0111 End If
0112Loop
0113If Use_Maintainable_Objects = True Then
0114 Set rsMaintenance = CurrentDb.OpenRecordset("SELECT Maintenance_Dates.Webref_Date FROM Maintenance_Dates WHERE (((Maintenance_Dates.Object)=""" & RunType & """));")
0115 If Not rsMaintenance.EOF Then
0116 rsMaintenance.MoveFirst
0117 rsMaintenance.Edit
0118 rsMaintenance.Fields(0) = start
0119 rsMaintenance.Update
0120 End If
0121End If
0122End_Of:
0123Set rsTableToRead = Nothing
0124Set rsMaintenance = Nothing
0125If Err.Number > 0 Then
0126 strLine = "Convert_Webrefs: " & RunType & " error. Number: " & Err.Number & ". Name: " & Err.Description
0127 Debug.Print Now() & " - "; strLine
0128Else
0129 Duration = Round((Now() - start) * 24 * 60 * 60, 2)
0130 If automatic_processing <> "Yes" Then
0131 strLine = "Convert_Webrefs: " & RunType & " (" & Duration & " seconds; " & j & " updates of " & i & " records)"
0132 Debug.Print Now() & " - "; strLine
0133 End If
0134End If
0135End Function

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


Source Code of: GetPrecisLink
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 6

Line-No. / Ref.Code Line
0001Public Function GetPrecisLink(Comment)
0002Dim CommentLocal As String
0003'Returns the link to a PDF-based Precis from the Comment.
0004CommentLocal = Nz(Comment)
0005GetPrecisLink = CommentLocal
0006End Function

Go To Top of This Page
Link to VBA Code Control Page


Source Code of: Reference_Webrefs
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 117
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Reference_Webrefs(strText, Calling_Type, Calling_ID, Calling_Timestamp, Optional ShowLink)
0002Dim x As Long
0003Dim Y As Long
0004Dim Weblink As Long
0005Dim strWebRef As String
0006Dim strText_Local As String
0007Dim strText_End As String
0008Dim qryString As String
0009Dim rsTableToRead As Recordset
0010Dim rsMissingWebrefs As Recordset
0011Dim WebRef_Missing_IDs_Open As Boolean
0012Dim Web_Reference As String
0013Dim Visible_Reference As String
0014Dim Display_Text As String
0015Dim Defunct_Reference As Boolean
0016Dim WebID As Integer
0017Dim Private_Area As String
0018Dim FairUse As String
0019Private_Area = "http://www.theotodman.com/PDFs/"
0020FairUse = "This document was found on the Web at a URL that no longer exists. I've added the document to my own site on a 'fair use' basis. If you are the author and wish me to remove it please let me know. "
0021FairUse = "<span title=""" & FairUse & """ style=""color:red"">Fair Use</span>"
0022If Len(strText) = 0 Then
0023 Reference_Webrefs = "Not Found"
0024 Exit Function
0025End If
0026strText_Local = strText
0027WebRef_Missing_IDs_Open = False
0028x = 1
0029x = InStr(x, strText_Local, "+W")
0030Reference_Webrefs = "Not Found"
0031Do While x > 0
0032 Reference_Webrefs = "Found"
0033 Y = InStr(x + 1, strText_Local, "W+")
0034 'Watch out for false positives in finding +W
0035 If Y = 0 Then
0036 x = x + 1
0037 Else
0038 If Y - x > 7 Then
0039 x = x + 1
0040 Else
0041 strWebRef = Mid(strText_Local, x + 2, Y - x - 2)
0042 If Not IsNumeric(strWebRef) Then
0043 x = x + 1
0044 Else
0045 Weblink = Trim(strWebRef)
0046 If Y > Len(strText_Local) - 2 Then
0047 strText_End = ""
0048 Else
0049 strText_End = Mid(strText_Local, Y + 2, Len(strText_Local))
0050 End If
0051 'Determine Web Link
0052 Web_Reference = ""
0053 qryString = "SELECT Webrefs_Table.ID, Webrefs_Table.Webref, Webrefs_Table.Display_Text, Webrefs_Table.[Defunct?] FROM Webrefs_Table WHERE (((Webrefs_Table.ID)=" & Weblink & "));"
0054 Set rsTableToRead = CurrentDb.OpenRecordset(qryString)
0055 If Not rsTableToRead.EOF Then
0056 rsTableToRead.MoveFirst
0057 WebID = rsTableToRead.Fields(0).Value
0058 Web_Reference = rsTableToRead.Fields(1).Value
0059 Display_Text = rsTableToRead.Fields(2).Value & ""
0060 Defunct_Reference = rsTableToRead.Fields(3).Value
0061 If Display_Text = "" Then
0062 Display_Text = "Link"
0063 End If
0064 If IsMissing(ShowLink) Then
0065 Visible_Reference = ""
0066 Else
0067 Visible_Reference = " (" & Web_Reference & ")"
0068 End If
0069 If Defunct_Reference = True Then
0070 If Visible_Reference = "" Then
0071 Visible_Reference = " (Defunct)"
0072 Else
0073 Visible_Reference = " - Defunct"
0074 End If
0075 End If
0076 'Check if in my private area ... add "fair use"
0077 If Left(Web_Reference, Len(Private_Area)) = Private_Area Then
0078 If Visible_Reference = "" Then
0079 Visible_Reference = " (" & FairUse & ")"
0080 Else
0081 Visible_Reference = " - " & FairUse
0082 End If
0083 End If
0084 Web_Reference = "<A HREF = """ & Web_Reference & """ TARGET = ""_top"">" & Display_Text & "</A>" & Visible_Reference
0085 'strText_Local = Left(strText_Local, x - 1) & IIf(Calling_Type <> "X", "<a name=""Off-Page_Link_W" & Weblink & "W""></a>", "") & Web_Reference & strText_End
0086 strText_Local = Left(strText_Local, x - 1) & "<a name=""Off-Page_Link_W" & Weblink & "W""></a>" & Web_Reference & strText_End
0087 x = x + Len(Web_Reference)
0088 Else
0089 WebID = 0
0090 Web_Reference = """Unknown Web Reference"""
0091 Debug.Print Now() & " - "; "Unknown WebRef", Weblink, Calling_Type, Calling_ID
0092 If WebRef_Missing_IDs_Open = False Then
0093 Set rsMissingWebrefs = CurrentDb.OpenRecordset("SELECT * FROM WebRef_Missing_IDs WHERE WebRef_Missing_IDs.ID = 0;")
0094 WebRef_Missing_IDs_Open = True
0095 End If
0096 rsMissingWebrefs.AddNew
0097 rsMissingWebrefs.Fields(1) = Weblink
0098 rsMissingWebrefs.Fields(2) = Calling_Type
0099 rsMissingWebrefs.Fields(3) = Calling_ID
0100 rsMissingWebrefs.Fields(4) = Calling_Timestamp / 1000
0101 rsMissingWebrefs.Fields(5) = Now()
0102 rsMissingWebrefs.Update
0103 'strText_Local = Left(strText_Local, x - 1) & IIf(Calling_Type <> "X", "<a name=""W" & Weblink & "W""></a>", "") & Web_Reference & strText_End
0104 strText_Local = Left(strText_Local, x - 1) & "<a name=""W" & Weblink & "W""></a>" & Web_Reference & strText_End
0105 End If
0106 If Calling_Type <> "X" Then
0107 OK = Cross_Reference_Add(Calling_Type, Calling_ID, Calling_Timestamp, "W", WebID, 0)
0108 End If
0109 Set rsTableToRead = Nothing
0110 End If
0111 End If
0112 End If
0113 x = InStr(x, strText_Local, "+W")
0114Loop
0115Set rsMissingWebrefs = Nothing
0116strText = strText_Local
0117End Function

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


Source Code of: Spider_Note_Remove_Section
Procedure Type: Public Function
Module: Spider
Lines of Code: 39
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Spider_Note_Remove_Section(strText)
0002Dim x As Long
0003Dim Y As Long
0004Dim strText_Local As String
0005Dim strText_End As String
0006Dim strPrefix As String
0007Dim strAffix As String
0008Dim i As Integer
0009If Len(strText) = 0 Then
0010 Spider_Note_Remove_Section = "Not Found"
0011 Exit Function
0012End If
0013i = 0
0014strPrefix = "<a name=""Section"
0015strAffix = ">"
0016strText_Local = strText
0017'Replace line-feeds while we're at it!
0018strText_Local = Replace(strText_Local, "<BR>", Chr(13) & Chr(10))
0019x = 1
0020x = InStr(x, strText_Local, strPrefix)
0021Spider_Note_Remove_Section = "Not Found"
0022Do While x > 0
0023 Spider_Note_Remove_Section = "Found"
0024 Y = InStr(x + 1, strText_Local, strAffix)
0025 'Watch out for false positives in finding strPrefix
0026 If Y = 0 Then
0027 x = x + 1
0028 Else
0029 If Y - x > 25 Then
0030 x = x + 1
0031 Else
0032 strText_End = Mid(strText_Local, Y + 1, Len(strText_Local))
0033 strText_Local = Left(strText_Local, x - 1) & strText_End
0034 End If
0035 End If
0036 x = InStr(x, strText_Local, strPrefix)
0037Loop
0038strText = strText_Local
0039End Function

Procedures Calling This Procedure (Spider_Note_Remove_Section) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page


Source Code of: Spider_Note_Reverse_Bullets
Procedure Type: Public Function
Module: Spider
Lines of Code: 49
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Spider_Note_Reverse_Bullets(strText)
0002Dim x As Long
0003Dim Y As Long
0004Dim strText_Local As String
0005Dim strText_End As String
0006Dim Bullet_Type As String
0007Dim Bullet_List As String
0008Dim List_Text As String
0009Dim strPrefix As String
0010Dim strAffix As String
0011Dim i As Integer
0012If Len(strText) = 0 Then
0013 Spider_Note_Reverse_Bullets = "Not Found"
0014 Exit Function
0015End If
0016i = 0
0017strPrefix = "L TYPE="""
0018strText_Local = strText
0019x = 1
0020x = InStr(x, strText_Local, strPrefix)
0021Spider_Note_Reverse_Bullets = "Not Found"
0022Do While x > 0
0023 Spider_Note_Reverse_Bullets = "Found"
0024 If Mid(strText_Local, x - 1, 1) = "U" Then
0025 Bullet_Type = "|..|"
0026 Bullet_List = "|.|"
0027 strAffix = "</UL>"
0028 Else
0029 Bullet_Type = "|99|"
0030 Bullet_List = "|1|"
0031 strAffix = "</OL>"
0032 End If
0033 x = x - 2
0034 Y = InStr(x, strText_Local, strAffix)
0035 'Watch out for false positives in finding strPrefix
0036 If Y = 0 Then
0037 x = x + 10
0038 Else
0039 List_Text = Mid(strText_Local, x, Y - x)
0040 List_Text = Mid(List_Text, InStr(List_Text, ">") + 1, Len(List_Text))
0041 strText_End = Mid(strText_Local, Y + Len(strAffix), Len(strText_Local))
0042 'Replace the list indicators
0043 List_Text = Replace(List_Text, "<LI>", Bullet_List)
0044 strText_Local = Left(strText_Local, x - 1) & Bullet_Type & List_Text & Bullet_Type & strText_End
0045 End If
0046 x = InStr(x + 1, strText_Local, strPrefix)
0047Loop
0048strText = strText_Local
0049End Function

Procedures Calling This Procedure (Spider_Note_Reverse_Bullets) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page


Source Code of: Spider_WebLinks_Tester_Page_Gen
Procedure Type: Public Function
Module: Spider
Lines of Code: 501
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Spider_WebLinks_Tester_Page_Gen(Optional Map, Optional Defunct)
0002Dim strOutputFolder As String
0003Dim strOutputFile As String
0004Dim strLine As String
0005Dim rsTableControl2 As Recordset
0006Dim i As Integer
0007Dim j As Integer
0008Dim k As Integer
0009Dim m As Integer
0010Dim FileName As String
0011Dim FileName_Root As String
0012Dim ifields As Integer
0013Dim strControlQuery As String
0014Dim rs As Recordset
0015Dim rsFooterControl As Recordset
0016Dim rsWebRef_Maps As Recordset
0017Dim rsWebLinkCheck_Map As Recordset
0018Dim x As String
0019Dim Link_Saved As String
0020Dim Link_Returned_Saved As String
0021Dim Link_Narr As String
0022Dim File_Sub As Integer
0023Dim strFile_Sub As String
0024Dim strJump_Table As String
0025Dim Issue_Saved As String
0026Dim strQuery As String
0027Dim Last_Regen As Date
0028Dim strLast_Regen As String
0029Dim Last_Regen_Day As Integer
0030Dim Last_Regen_Month As String
0031Dim Last_Regen_Year As Integer
0032Dim strLink_Called As String
0033Dim strObject As String
0034Dim Date_Webrefs_Table_Max As Date
0035Dim Date_WebRef_Maps_Max As Date
0036Dim strJump_Page_Title As String
0037Dim Missing_Page As Boolean
0038Dim Repeat_Line As Boolean
0039Dim Same_Line As Boolean
0040Dim ID_Saved As String
0041Dim strQuery2 As String
0042Dim strDefunct As String
0043If IsMissing(Map) Then 'Use Links from the Spider
0044 DoCmd.RunSQL ("DELETE * FROM WebLinkCheck;")
0045 DoCmd.OpenQuery ("Spider_Weblinks_Add")
0046 'Prune - The Raw_Links table contains ancient stuff no longer relevant to current pages
0047 strQuery = "SELECT Min(Last_Run) AS MinOfLast_Run FROM Website_Regen_Control;"
0048 Set rs = CurrentDb.OpenRecordset(strQuery)
0049 rs.MoveFirst
0050 Last_Regen = rs.Fields(0) - 1
0051 Last_Regen_Day = Day(Last_Regen)
0052 Last_Regen_Month = Month(Last_Regen)
0053 Last_Regen_Month = MonthName(Last_Regen_Month)
0054 Last_Regen_Year = Year(Last_Regen)
0055 strLast_Regen = Last_Regen_Day & " " & Last_Regen_Month & " " & Last_Regen_Year
0056 strLast_Regen = "31 December 2016" 'Bodge ... as if the Spider has not been run since the last regen, everything gets deleted!
0057 'Correction to allow for standard MS Date muddle - the above query was deleting everything in February!
0058 strQuery = "DELETE WebLinkCheck.*, WebLinkCheck.Timestamp_Logged FROM WebLinkCheck WHERE (((WebLinkCheck.Timestamp_Logged)<#" & strLast_Regen & "#));"
0059 DoCmd.RunSQL (strQuery)
0060 FileName_Root = "WebLinks_Tester"
0061 Set rs = Nothing
0062Else
0063 'Use Links from WebRef_Maps
0064 'First check if need to re-generate the WebRef_Maps table
0065 Set rs = CurrentDb.OpenRecordset("SELECT Max(Webrefs_Table.Date_Created) AS MaxOfDate_Created FROM Webrefs_Table;")
0066 rs.MoveFirst
0067 Date_Webrefs_Table_Max = rs.Fields(0)
0068 Set rs = Nothing
0069 Set rs = CurrentDb.OpenRecordset("SELECT Max(WebRef_Maps.Timestamp) AS MaxOfTimestamp FROM WebRef_Maps;")
0070 rs.MoveFirst
0071 Date_WebRef_Maps_Max = rs.Fields(0)
0072 Set rs = Nothing
0073 If Date_WebRef_Maps_Max < Date_Webrefs_Table_Max Then
0074 Map_WebRefs
0075 End If
0076 'Now create the WebLinkCheck_Map table
0077 DoCmd.RunSQL ("DELETE * FROM WebLinkCheck_Map;")
0078 Set rsWebRef_Maps = CurrentDb.OpenRecordset("SELECT WebRef_Maps.WebRef_ID, WebRef_Maps.Object_Type, WebRef_Maps.Object_ID, WebRef_Maps.Object_Sub_ID, Webrefs_Table.Webref, Webrefs_Table.Alt_Ref, Webrefs_Table.Issue, Webrefs_Table.[Defunct?], Webrefs_Table.Display_Text, Webrefs_Table.Date_Last_Checked, Webrefs_Table.Check_Time, WebRef_Maps.Object_Security, Webrefs_Table.Defunct_Explanation FROM WebRef_Maps INNER JOIN Webrefs_Table ON WebRef_Maps.WebRef_ID = Webrefs_Table.ID;")
0079 Set rsWebLinkCheck_Map = CurrentDb.OpenRecordset("SELECT * FROM WebLinkCheck_Map;")
0080 rsWebRef_Maps.MoveFirst
0081 Do While Not rsWebRef_Maps.EOF
0082 rsWebLinkCheck_Map.AddNew
0083 rsWebLinkCheck_Map.Fields(0) = rsWebRef_Maps.Fields(0) 'WebRef ID
0084 rsWebLinkCheck_Map.Fields(1) = rsWebRef_Maps.Fields(4) 'Link Called
0085 strObject = rsWebRef_Maps.Fields(1)
0086 Select Case strObject
0087 Case "Author"
0088 Set rs = CurrentDb.OpenRecordset("SELECT * FROM Authors WHERE Authors.Author_ID = " & rsWebRef_Maps.Fields(2) & ";")
0089 If Not rs.EOF Then
0090 rs.MoveFirst
0091 strLink_Called = "Authors/" & Left(rs.Fields(0), 1) & "/Author_" & rs.Fields(0)
0092 Else
0093 strLink_Called = ""
0094 End If
0095 Set rs = Nothing
0096 Case "Book"
0097 strLink_Called = "BookSummaries/BookSummary_" & Mid(rsWebRef_Maps.Fields(2) + 1000000, 3, 2) & "/BookPaperAbstracts/BookPaperAbstracts_" & rsWebRef_Maps.Fields(2)
0098 'Need a check for the Note Group for Secure_Jen here!
0099 Case "Note"
0100 If rsWebRef_Maps.Fields(11) & "" = "10" Then
0101 strLink_Called = "Secure_Jen/Notes_" & Val(Mid(rsWebRef_Maps.Fields(2) + 1000000, 4, 2)) & "/Notes_" & rsWebRef_Maps.Fields(2)
0102 Else
0103 strLink_Called = "Notes/Notes_" & Val(Mid(rsWebRef_Maps.Fields(2) + 1000000, 4, 2)) & "/Notes_" & rsWebRef_Maps.Fields(2)
0104 End If
0105 'And here!
0106 Case "Note_Archive"
0107 If rsWebRef_Maps.Fields(11) & "" = "10" Then
0108 strLink_Called = "Secure_Jen/Notes_" & Val(Mid(rsWebRef_Maps.Fields(2) + 1000000, 4, 2)) & "/Notes_" & rsWebRef_Maps.Fields(2) & "_" & rsWebRef_Maps.Fields(3)
0109 Else
0110 strLink_Called = "Notes/Notes_" & Val(Mid(rsWebRef_Maps.Fields(2) + 1000000, 4, 2)) & "/Notes_" & rsWebRef_Maps.Fields(2) & "_" & rsWebRef_Maps.Fields(3)
0111 End If
0112 Case "Paper"
0113 strLink_Called = "Abstracts/Abstract_" & Mid(rsWebRef_Maps.Fields(2) + 1000000, 3, 2) & "/Abstract_" & rsWebRef_Maps.Fields(2)
0114 Case Else
0115 Stop
0116 End Select
0117 strLink_Called = "<a href = ""../" & strLink_Called & ".htm"">Link</a>"
0118 rsWebLinkCheck_Map.Fields(2) = strLink_Called 'Called From
0119 rsWebLinkCheck_Map.Fields(3) = rsWebRef_Maps.Fields(5) 'Link Returned
0120 rsWebLinkCheck_Map.Fields(4) = rsWebRef_Maps.Fields(6) 'Issue
0121 rsWebLinkCheck_Map.Fields(5) = IIf(rsWebRef_Maps.Fields(7) = True, "Yes", "") 'Defunct?
0122 rsWebLinkCheck_Map.Fields(6) = rsWebRef_Maps.Fields(8) 'Display Text
0123 rsWebLinkCheck_Map.Fields(7) = rsWebRef_Maps.Fields(9) 'Date Last Checked
0124 rsWebLinkCheck_Map.Fields(8) = rsWebRef_Maps.Fields(10) 'Seconds
0125 rsWebLinkCheck_Map.Fields(9) = rsWebRef_Maps.Fields(12) 'Explanation
0126 rsWebLinkCheck_Map.Update
0127 rsWebRef_Maps.MoveNext
0128 Loop
0129 FileName_Root = "WebLinks_Tester_Map"
0130 Set rsWebRef_Maps = Nothing
0131 Set rsWebLinkCheck_Map = Nothing
0132End If
0133If Not IsMissing(Defunct) Then
0134 FileName_Root = FileName_Root & "_NotDefunct"
0135End If
0136Issue_Saved = ""
0137If IsMissing(Defunct) Then
0138 strDefunct = ""
0139Else
0140 strDefunct = "<br>(Not yet investigated and set as Defunct)"
0141End If
0142If IsMissing(Map) Then 'Use Links from the Spider
0143 If IsMissing(Defunct) Then
0144 strQuery2 = "Spider_Weblink_Fix_Check_Counts"
0145 Else
0146 strQuery2 = "Spider_Weblink_Fix_Check_Counts_NotDefunct"
0147 End If
0148 Set rsTableControl2 = CurrentDb.OpenRecordset(strQuery2)
0149 If rsTableControl2.EOF Then
0150 MsgBox ("No records in " & strQuery2)
0151 Exit Function
0152 Else
0153 DoEvents
0154 rsTableControl2.MoveLast
0155 DoEvents
0156 End If
0157Else
0158 If IsMissing(Defunct) Then
0159 strQuery2 = "Weblink_Fix_Check_Counts"
0160 Else
0161 strQuery2 = "Weblink_Fix_Check_Counts_NotDefunct"
0162 End If
0163 Set rsTableControl2 = CurrentDb.OpenRecordset(strQuery2)
0164 If rsTableControl2.EOF Then
0165 MsgBox ("No records in " & strQuery2)
0166 Exit Function
0167 Else
0168 DoEvents
0169 rsTableControl2.MoveLast
0170 DoEvents
0171 End If
0172End If
0173'Create the jump table ...
0174ifields = rsTableControl2.RecordCount
0175rsTableControl2.MoveFirst
0176strJump_Table = "<TABLE class = ""Bridge"" WIDTH=1200>"
0177strJump_Table = strJump_Table & "<tr>"
0178For i = 1 To ifields
0179 If i = 1 Then
0180 strFile_Sub = ""
0181 Else
0182 strFile_Sub = "_" & i - 1
0183 End If
0184 strJump_Page_Title = rsTableControl2.Fields(0)
0185 strJump_Page_Title = Replace(strJump_Page_Title, "zMissing", "WebRef Missing")
0186 strJump_Page_Title = Replace(strJump_Page_Title, "URL ", "URL<br>") & " <br>(" & rsTableControl2.Fields(1) & ")"
0187 strJump_Table = strJump_Table & "<th><a href=""" & FileName_Root & strFile_Sub & ".htm"">" & strJump_Page_Title & "</a></th>"
0188 rsTableControl2.MoveNext
0189Next i
0190strJump_Table = strJump_Table & "</tr></TABLE>"
0191If IsMissing(Map) Then 'Use Links from the Spider
0192 strQuery2 = "Spider_Weblink_Fix_Check"
0193Else
0194 strQuery2 = "Weblink_Fix_Check_Map"
0195End If
0196If Not IsMissing(Defunct) Then
0197 strQuery2 = strQuery2 & "_NotDefunct"
0198End If
0199Set rsTableControl2 = CurrentDb.OpenRecordset(strQuery2)
0200rsTableControl2.MoveFirst
0201ifields = rsTableControl2.Fields.Count
0202rsTableControl2.MoveFirst
0203strOutputFolder = TheoWebsiteRoot & "\Test\"
0204Set fsoTextFile2 = New FileSystemObject
0205File_Sub = 0
0206Link_Returned_Saved = ""
0207Link_Saved = ""
0208ID_Saved = ""
0209Same_Line = False
0210'Rows
0211Do While Not rsTableControl2.EOF
0212 If rsTableControl2.Fields(4) <> Issue_Saved Then
0213 Issue_Saved = rsTableControl2.Fields(4)
0214 ID_Saved = ""
0215 'Close off previous file ...
0216 If File_Sub > 0 Then
0217 If Same_Line = True Then
0218 tsTextFile.WriteLine strLine & "</TD></TR>"
0219 Same_Line = False
0220 End If
0221 'Footer
0222 strLine = "</TABLE><BR>"
0223 tsTextFile.WriteLine strLine
0224 'Add link to previous & next file ...
0225 If File_Sub > 1 Then
0226 If File_Sub = 2 Then
0227 strFile_Sub = ""
0228 Else
0229 strFile_Sub = "_" & File_Sub - 2
0230 End If
0231 strLine = "<h3><a href=""" & FileName_Root & strFile_Sub & ".htm"">" & "Previous File</a> : "
0232 Else
0233 strLine = "<h3>"
0234 End If
0235 strFile_Sub = "_" & File_Sub
0236 strLine = strLine & "<a href=""" & FileName_Root & strFile_Sub & ".htm"">" & "Next File</a></h3>"
0237 tsTextFile.WriteLine strLine
0238 'Page Footer
0239 strLine = ""
0240 strControlTable = "WebLinkCheck_Ctrl"
0241 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;"
0242 Set rsFooterControl = CurrentDb.OpenRecordset(strControlQuery)
0243 rsFooterControl.MoveFirst
0244 Do While Not rsFooterControl.EOF
0245 strLine = strLine & rsFooterControl.Fields(0)
0246 OK = Replace_Timestamp(strLine)
0247 rsFooterControl.MoveNext
0248 Loop
0249 tsTextFile.WriteLine strLine
0250 OK = CopyToTransfer(strOutputFolder, FileName)
0251 End If
0252 'Output a new file + headers
0253 If File_Sub = 0 Then
0254 strFile_Sub = ""
0255 Else
0256 strFile_Sub = "_" & File_Sub
0257 End If
0258 FileName = FileName_Root & strFile_Sub & ".htm"
0259 strOutputFile = strOutputFolder & FileName
0260 Set tsTextFile = fsoTextFile2.CreateTextFile(strOutputFile, True, True)
0261 strLine = "<!DOCTYPE html><HTML lang=""en"">"
0262 tsTextFile.WriteLine strLine
0263 strLine = "<HEAD><meta <meta charset=""utf-8"">"
0264 tsTextFile.WriteLine strLine
0265 strLine = "<TITLE>Theo Todman's Web-Links Test Webpage</TITLE>"
0266 tsTextFile.WriteLine strLine
0267 strLine = "<link href=""../TheosStyle.css"" rel=""stylesheet"" type=""text/css""><link rel=""shortcut icon"" href=""../TT_ICO.png"" /></HEAD><BODY>"
0268 tsTextFile.WriteLine strLine
0269 If IsMissing(Map) Then
0270 strLine = "<H1>Theo Todman's Web-Links Test Webpage - Spider Version" & strDefunct & "</H1><CENTER>"
0271 Else
0272 strLine = "<H1>Theo Todman's Web-Links Test Webpage - WebRefs Mapper Version" & strDefunct & "</H1><CENTER>"
0273 End If
0274 tsTextFile.WriteLine strLine
0275 If IsMissing(Map) Then
0276 strLine = "<p>The table of links below lists all the external links" & Replace(strDefunct, "<br>", " ") & " from my website - obtained via the Spider - with which there is some issue that needs correcting. The main table is preceeded by a Jump Table of the sub-pages into which this page is now split; counts are of unique WebRefs (or URLs where the WebRef is missing). All this is still under development. </p>"
0277 Else
0278 strLine = "<p>The table of links below lists all the external links" & Replace(strDefunct, "<br>", " ") & " from my website - obtained by mapping WebRefs against the Objects databases - with which there is some issue that needs correcting. The main table is preceeded by a Jump Table of the sub-pages into which this page is now split; counts are of unique WebRefs. Note that composite pages - eg. Note Print and BookPaperAbstracts - are not included here. All this is still under development. </p>"
0279 End If
0280 tsTextFile.WriteLine strLine
0281 strJump_Page_Title = rsTableControl2.Fields(4)
0282 If InStr(strJump_Page_Title, "zMissing") > 0 Then
0283 strJump_Page_Title = Replace(strJump_Page_Title, "zMissing", "WebRef Missing")
0284 Missing_Page = True
0285 Else
0286 Missing_Page = False
0287 End If
0288 'Add a link to Jump Table
0289 tsTextFile.WriteLine strJump_Table
0290 File_Sub = File_Sub + 1
0291 strLine = "<H2>Page: " & strJump_Page_Title & "</H2>"
0292 tsTextFile.WriteLine strLine
0293 'Explain the "missing" page
0294 If Missing_Page = True Then
0295 strLine = "<p>This page ought to be empty, but items can arise normally if the URL of a Webref is corrected between Spider runs. Then the link from the URL to the WebRefs table fails. But it shouldn't cause a problem on the site itself, other than not yet fixing the problem the URL was changed to fix. </p>"
0296 tsTextFile.WriteLine strLine
0297 End If
0298 'Headings
0299 If Not rsTableControl2.EOF Then
0300 strLine = "<TABLE class = ""ReadingList"" WIDTH=1500>"
0301 tsTextFile.WriteLine strLine
0302 End If
0303 strLine = "<TR>"
0304 tsTextFile.WriteLine strLine
0305 'Headers
0306 j = 0
0307 Do While j < ifields - 1
0308 If j <> 4 Then 'Ignore "Issue" column, as it's always the same & is in the heading
0309 strLine = "<TH class = ""BridgeCenter"">"
0310 strLine = strLine & rsTableControl2.Fields(j).Name & "</TH>"
0311 tsTextFile.WriteLine strLine
0312 End If
0313 j = j + 1
0314 Loop
0315 strLine = "</TR>"
0316 tsTextFile.WriteLine strLine
0317 End If
0318 j = 0
0319 Do While j < ifields - 1
0320 If j <> 4 Then 'Ignore "Issue" column, as it's always the same & is in the heading
0321 x = rsTableControl2.Fields(j) & ""
0322 Select Case j
0323 Case 0
0324 If Missing_Page = True Then
0325 x = "Missing"
0326 End If
0327 If x <> ID_Saved Then
0328 If Same_Line = True Then
0329 tsTextFile.WriteLine strLine & "</TD></TR>"
0330 Same_Line = False
0331 End If
0332 ID_Saved = x
0333 Repeat_Line = False
0334 End If
0335 If Same_Line = False Then
0336 strLine = "<TR class = ""BridgeCenter"">"
0337 tsTextFile.WriteLine strLine
0338 strLine = "<TD class = ""BridgeCenter"">"
0339 Else
0340 x = ""
0341 End If
0342 Case 1
0343 If x = Link_Saved Then
0344 Repeat_Line = True
0345 If Same_Line = False Then
0346 strLine = "<TD class = ""BridgeLeft"">"
0347 x = "As above &uarr;: Further links to the right &rarr; "
0348 strLine = strLine & x & "</TD>"
0349 tsTextFile.WriteLine strLine
0350 Else
0351 x = ""
0352 End If
0353 Else
0354 strLine = "<TD class = ""BridgeLeft"">"
0355 Link_Saved = x
0356 Repeat_Line = False
0357 Same_Line = False
0358 Link_Narr = x
0359 If Len(Link_Narr) > 50 Then
0360 Link_Narr = Left(x, 40) & " ..."
0361 End If
0362 x = "<a href=""" & x & """>" & Link_Narr & "</a>"
0363 End If
0364 Link_Saved = rsTableControl2.Fields(j)
0365 Case 2
0366 If Repeat_Line = False Then
0367 strLine = "<TD class = ""BridgeCenter"">"
0368 Else
0369 If Same_Line = False Then
0370 strLine = "<TD class = ""BridgeLeft"" colspan=8>"
0371 Same_Line = True
0372 End If
0373 End If
0374 x = Replace(x, """>Link</a>", "#Off-Page_Link_W" & rsTableControl2.Fields(0) & "W"">Link</a>")
0375 If InStr(x, "/Abstract_") > 0 Then
0376 x = Replace(x, "Link</a>", "Paper Abstract</a>")
0377 End If
0378 k = InStr(x, "/Notes_")
0379 If k > 0 Then
0380 x = Replace(x, "Link</a>", "Note</a>")
0381 If InStr(x, "Print") > 0 Then
0382 x = Replace(x, "Note</a>", "Note Print</a>")
0383 Else
0384 k = InStr(k + 1, x, "/Notes_")
0385 m = InStr(k + Len("/Notes_") + 1, x, "_")
0386 If m > 0 And InStr(k + Len("/Notes_") + 1, x, ".") > m Then
0387 x = Replace(x, "Note</a>", "Note Archive</a>")
0388 End If
0389 End If
0390 End If
0391 If InStr(x, "BookPaperAbstract") > 0 Then
0392 x = Replace(x, "Link</a>", "Book Abstract</a>")
0393 End If
0394 If InStr(x, "/BookSummary_") > 0 Then
0395 x = Replace(x, "Link</a>", "Book</a>")
0396 End If
0397 If InStr(x, "/PaperSummary_") > 0 Then
0398 x = Replace(x, "Link</a>", "Paper</a>")
0399 End If
0400 If InStr(x, "ConcatenatedNotes") > 0 Then
0401 x = Replace(x, "Link</a>", "Concatenated</a>")
0402 End If
0403 If InStr(x, "/Authors/") > 0 Then
0404 x = Replace(x, "Link</a>", "Author</a>")
0405 End If
0406 If Same_Line = True Then
0407 x = x & "; "
0408 End If
0409 Case 3
0410 If Repeat_Line = False Then
0411 strLine = "<TD class = ""BridgeLeft"">"
0412 Link_Narr = x & ""
0413 If Link_Narr <> "" Then
0414 Link_Returned_Saved = Link_Narr
0415 If Len(Link_Narr) > 50 Then
0416 Link_Narr = Left(x, 40) & " ..."
0417 End If
0418 x = "<a href=""" & x & """>" & Link_Narr & "</a>"
0419 Else
0420 x = "&nbsp;"
0421 Link_Returned_Saved = ""
0422 End If
0423 Else
0424 x = ""
0425 End If
0426 Case 6
0427 If Repeat_Line = False Then
0428 strLine = "<TD class = ""BridgeLeft"">"
0429 If x = "" Then
0430 x = "&nbsp;"
0431 End If
0432 Else
0433 x = ""
0434 End If
0435 Case 7 'Date Last Checked
0436 If Repeat_Line = False Then
0437 strLine = "<TD class = ""BridgeCenter"">"
0438 x = Left(x, 10)
0439 Else
0440 x = ""
0441 End If
0442 Case 9
0443 If Repeat_Line = False Then
0444 strLine = "<TD class = ""BridgeLeft"">"
0445 If x = "" Then
0446 x = "&nbsp;"
0447 End If
0448 Else
0449 x = ""
0450 End If
0451 Case Else
0452 If Repeat_Line = False Then
0453 strLine = "<TD class = ""BridgeCenter"">"
0454 If x = "" Then
0455 x = "&nbsp;"
0456 End If
0457 Else
0458 x = ""
0459 End If
0460 End Select
0461 strLine = strLine & x
0462 If Repeat_Line = False Then
0463 strLine = strLine & "</TD>"
0464 tsTextFile.WriteLine strLine
0465 End If
0466 End If
0467 j = j + 1
0468 Loop
0469 If Repeat_Line = False Then
0470 strLine = "</TR>"
0471 End If
0472 rsTableControl2.MoveNext
0473Loop
0474'Final Footer
0475strLine = "</TABLE><BR>"
0476tsTextFile.WriteLine strLine
0477'Add link to previous ...
0478If File_Sub > 1 Then
0479 If File_Sub = 2 Then
0480 strFile_Sub = ""
0481 Else
0482 strFile_Sub = "_" & File_Sub - 2
0483 End If
0484 strLine = "<h3><a href=""" & FileName_Root & strFile_Sub & ".htm"">" & "Previous File</a></h3>"
0485 tsTextFile.WriteLine strLine
0486End If
0487'Final Page Footer
0488strLine = ""
0489strControlTable = "WebLinkCheck_Ctrl"
0490 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;"
0491Set rsFooterControl = CurrentDb.OpenRecordset(strControlQuery)
0492rsFooterControl.MoveFirst
0493Do While Not rsFooterControl.EOF
0494 strLine = strLine & rsFooterControl.Fields(0)
0495 OK = Replace_Timestamp(strLine)
0496 rsFooterControl.MoveNext
0497Loop
0498tsTextFile.WriteLine strLine
0499 OK = CopyToTransfer(strOutputFolder, FileName)
0500Set tsTextFile = Nothing
0501End Function

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


© Theo Todman, June 2007 - April 2026. 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