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

cmdPaperCitings_ClickRegen_Note_Links_ArchivedCreateNotesWebPagesSpider_WebLinks_Tester_Brief_Page_Gen
WebpageGenBookCitingsPageWebpageGenNotePapersLinks..

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

Go to top of page



Source Code of: cmdPaperCitings_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 30
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Private Sub cmdPaperCitings_Click()
0002Dim strMessage As String
0003Dim StartTime As Double
0004Dim rsTableToRead As Recordset
0005Dim rsTableToRead2 As Recordset
0006Dim Duration As Double
0007Dim strRunTime As String
0008Dim RunDate As Date
0009 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM BookPaperControl WHERE ID = ""WebpageGenPaperCitations"";")
0010RunDate = rsTableToRead.Fields(1)
0011strRunTime = Round(rsTableToRead.Fields(2), 1)
0012strMessage = "Do you want to regenerate the ""Paper Citations Links"" page (after first regenerating the individual Paper Citations pages)?"""
0013strMessage = strMessage & Chr$(10) & "The last run on " & RunDate & " took " & strRunTime & " minutes."
0014RootCreated = ""
0015If MsgBox(strMessage, vbYesNo) = vbYes Then
0016 StartTime = Now()
0017 WebpageGenPaperCitings ("Yes")
0018 WebpageGenPaperCitingsPage
0019 Duration = Round((Now() - StartTime) * 24 * 60, 1)
0020 rsTableToRead.Edit
0021 rsTableToRead.Fields(1) = Now()
0022 rsTableToRead.Fields(2) = Duration
0023 rsTableToRead.Update
0024Else
0025 Exit Sub
0026End If
0027MsgBox "Paper Citations Pages Creation Complete in " & Duration & " minutes.", vbOKOnly, "Create Paper Citations Pages"
0028Set rsTableToRead = Nothing
0029Set rsTableToRead2 = Nothing
0030End Sub

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


Source Code of: CreateNotesWebPages
Procedure Type: Public Sub
Module: General_Subroutines
Lines of Code: 190
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub CreateNotesWebPages(Optional NoMessages)
0002Dim fsoTextFile As FileSystemObject
0003Dim rsTableToRead As Recordset
0004Dim rsTableControl As Recordset
0005Dim rsTableToUpdate As Recordset
0006Dim rsNotesLinks As Recordset
0007Dim strControlQuery As String
0008Dim StartTime As Date
0009Dim Duration
0010Dim Temp_Note_ID
0011Dim strNoMessages As String
0012Dim Note_Text_Saved As String
0013If IsMissing(NoMessages) Then
0014 strNoMessages = "No"
0015Else
0016 strNoMessages = NoMessages
0017End If
0018 Find_Functors
0019StartTime = Now()
0020Last_Changed_Timestamp = StartTime * 1000
0021 OK = Convert_Webrefs("Note", "Full")
0022If Archive_Notes_Now = "Yes" Then
0023 Archive_Notes
0024End If
0025If Regen_Notes_Only = "No" Then
0026 'If "Changed Notes Only", need to restrict the Notes records read ...
0027 If Changed_Notes_Only = "Yes" Then
0028 If Include_Associated_Notes = "Yes" Then
0029 strControlQuery = "SELECT Notes_List_Auto.* FROM Notes_List_Auto LEFT JOIN Active_Notes_Full ON Notes_List_Auto.ID = Active_Notes_Full.ID WHERE (((Active_Notes_Full.ID) Is Not Null));"
0030 Else
0031 If Temp_Notes_Only = "Yes" Then
0032 strControlQuery = "SELECT Notes_List_Auto.* FROM Notes_List_Auto LEFT JOIN Notes_Archive_Temp ON Notes_List_Auto.ID = Notes_Archive_Temp.ID WHERE Notes_List_Auto.Status = ""Temp"" ORDER BY Notes_List_Auto.ID;"
0033 Else
0034 strControlQuery = "SELECT Notes_List_Auto.* FROM Notes_List_Auto LEFT JOIN Notes_Archive_Temp ON Notes_List_Auto.ID = Notes_Archive_Temp.ID WHERE Notes_Archive_Temp.ID Is Not Null ORDER BY Notes_List_Auto.ID;"
0035 End If
0036 End If
0037 Else
0038 If Temp_Notes_Only = "Yes" Then
0039 strControlQuery = "SELECT Notes_List_Auto.* FROM Notes_List_Auto LEFT JOIN Notes_Archive_Temp ON Notes_List_Auto.ID = Notes_Archive_Temp.ID WHERE Notes_List_Auto.Status = ""Temp"" ORDER BY Notes_List_Auto.ID;"
0040 End If
0041 End If
0042Else
0043 'Specifically-chosen
0044 strControlQuery = "SELECT Notes_List_Auto.* FROM Notes_List_Auto INNER JOIN Notes_To_Regen ON Notes_List_Auto.ID = Notes_To_Regen.Note_ID ORDER BY Notes_List_Auto.ID;"
0045End If
0046Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0047If Regenerate_the_Links = "Yes" Then
0048 'Regenerate the Note, Note_Archive, Note-Paper & Note-Book Links
0049 Regen_Note_Links
0050 OK = Regen_Note_Links_Archived
0051 Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0052 OK = Regen_Note_Book_Links(rsTableToRead, 0, 2, 12) 'Note: uses Frozen_Timestamp (always Zero) for Timestamp
0053 Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0054 OK = Regen_Note_Paper_Links(rsTableToRead, 0, 2, 12)
0055End If
0056Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0057If Not rsTableToRead.EOF Then
0058 rsTableToRead.MoveFirst
0059End If
0060'Notes_List_Auto Fields
0061'0 = ID
0062'1 = Item_Title
0063'2 = Item_Text
0064'3 = Jump_Table?
0065'4 = Note_Group
0066'5 = Master Note
0067'6 = Last_Changed
0068'7 = Private?
0069'8 = ReadingList?
0070'9 = Title?
0071'10 = Respondent?
0072'11 = Status
0073'12 = Frozen_Timestamp
0074'13 = Immediate_Promotion
0075'14 = Note_Quality
0076'15 = Temp_Note_Timestamp
0077'Temp Notes: Update the timestamp and check for Functors ...
0078If Not rsTableToRead.EOF Then
0079 rsTableToRead.MoveFirst
0080 Do While Not rsTableToRead.EOF
0081 If (rsTableToRead.Fields(11) & "" = "Temp") Then 'Temp Note
0082 If (rsTableToRead.Fields(13) = True) Then 'Immediate Promotion
0083 Set rsTableToUpdate = CurrentDb.OpenRecordset("SELECT Notes.ID, Notes.Last_Changed FROM Notes WHERE (((Notes.ID)=" & rsTableToRead.Fields(0) & "));")
0084 If Not rsTableToUpdate.EOF Then
0085 rsTableToUpdate.MoveFirst
0086 rsTableToUpdate.Edit
0087 rsTableToUpdate.Fields(1) = Last_Changed_Timestamp
0088 rsTableToUpdate.Update
0089 End If
0090 Set rsTableToUpdate = Nothing
0091 End If
0092 'Check for Functors
0093 Note_Text_Saved = rsTableToRead.Fields(2) & ""
0094 OK = Functor(rsTableToRead.Fields(0), rsTableToRead.Fields(1), Note_Text_Saved)
0095 If OK = "Yes" Then
0096 'Update
0097 Set rsTableToUpdate = CurrentDb.OpenRecordset("SELECT Notes.ID, Notes.Item_Text FROM Notes WHERE (((Notes.ID)=" & rsTableToRead.Fields(0) & "));")
0098 If Not rsTableToUpdate.EOF Then
0099 rsTableToUpdate.MoveFirst
0100 rsTableToUpdate.Edit
0101 rsTableToUpdate.Fields(1) = Note_Text_Saved
0102 rsTableToUpdate.Update
0103 End If
0104 Set rsTableToUpdate = Nothing
0105 End If
0106 End If
0107 rsTableToRead.MoveNext
0108 Loop
0109 rsTableToRead.MoveFirst
0110End If
0111 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = ""Notes"") And ((Website_Control.Section) = ""Text"")) ORDER BY Website_Control.Line;"
0112Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0113If Not rsTableToRead.EOF Then
0114 rsTableToRead.MoveFirst
0115End If
0116'Output the Notes
0117Do While Not rsTableToRead.EOF
0118 OutputNotesWebPage (rsTableToRead.Fields(0))
0119 'Next Note
0120 rsTableToRead.MoveNext
0121Loop
0122Finish_Off:
0123If automatic_processing = "Yes" Then
0124 If Done_The_Jumps = True Then
0125 GoTo Tidy_Up
0126 Else
0127 Done_The_Jumps = True
0128 End If
0129End If
0130'Create the first-level notes Jump Pages (notes by Notes-Group)
0131 JumpTableTitles_Recent_Control
0132'Notes Jump Pages ... one for each active Notes Group
0133 strControlQuery = "SELECT Note_Groups.ID, Note_Groups.Note_Group, Note_Groups.Narrative FROM Note_Groups ORDER BY Note_Groups.ID;"
0134Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0135rsTableToRead.MoveFirst
0136'Refresh the Master Notes tables
0137 Find_Master_Notes
0138Notes_Recent = 0 'Prints all notes. If > 0, changed in last n days.
0139Do While Notes_Recent < 29
0140 rsTableToRead.MoveFirst
0141 Do While Not rsTableToRead.EOF
0142 Notes_Group_ID = rsTableToRead.Fields(0).Value
0143 Notes_Group = rsTableToRead.Fields(1).Value & IIf(Notes_Recent > 0, " - Updated in the last " & Notes_Recent & " days - ", "")
0144 Notes_Group_Narrative = rsTableToRead.Fields(2).Value & ""
0145 strControlTable = "Jump_Table_Titles_Notes"
0146 strOutputFileShort = "Notes_Jump_" & Notes_Group_ID & IIf(Notes_Recent > 0, "_Recent_" & Notes_Recent, "")
0147 strFileName = strOutputFileShort & ".htm"
0148 strTargetFileShort = "Notes"
0149 If Notes_Group_ID = 10 Then
0150 strOutputRoot = TheoWebsiteRoot & "\Secure_Jen\"
0151 Else
0152 strOutputRoot = TheoWebsiteRoot & "\Notes\"
0153 End If
0154 strFolder = strOutputRoot
0155 strOutputFile = strOutputRoot & strOutputFileShort
0156 strTargetFile = strOutputRoot & strTargetFileShort
0157 strDataQuery = "Notes_Jump"
0158 strSplitTable = "Yes"
0159 JumpTableTitles
0160 rsTableToRead.MoveNext
0161 Loop
0162 Notes_Recent = Notes_Recent + 7
0163 If Notes_Recent = 21 Then 'Don't bother with 3-week
0164 Notes_Recent = Notes_Recent + 7
0165 End If
0166Loop
0167Tidy_Up:
0168'Tidy Up
0169Set rsNotesLinks = Nothing
0170Set rsTableControl = Nothing
0171Set rsTableToRead = Nothing
0172Set fsoTextFile = Nothing
0173Duration = Round((Now() - StartTime) * 24 * 60, 1)
0174If automatic_processing = "Yes" Then
0175Else
0176 Set rsTableToRead = CurrentDb.OpenRecordset("Latest_Archives")
0177 If Not rsTableToRead.EOF Then
0178 DoCmd.OpenQuery ("Latest_Archives")
0179 End If
0180 Set rsTableToRead = Nothing
0181 If strNoMessages = "No" Then
0182 If Duration < 1 Then
0183 Duration = Round((Now() - StartTime) * 24 * 60 * 60)
0184 MsgBox Now() & ": Notes Webpage Creation Complete in " & Duration & " seconds.", vbOKOnly, "Create Notes Web Pages"
0185 Else
0186 MsgBox Now() & ": Notes Webpage Creation Complete in " & Duration & " minutes.", vbOKOnly, "Create Notes Web Pages"
0187 End If
0188 End If
0189End If
0190End Sub

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


Source Code of: Regen_Note_Links_Archived
Procedure Type: Public Function
Module: New Code
Lines of Code: 189
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Regen_Note_Links_Archived(Optional Note_ID, Optional Note_Timestamp)
0002Dim strControlQuery As String
0003Dim strLine As String
0004Dim rsTableToRead As Recordset
0005Dim rsNotesLinks As Recordset
0006Dim rsLatestTimestamp As Recordset
0007Dim x As Long
0008Dim Y As Long
0009Dim z As Long
0010Dim z_Saved As Long
0011Dim iSuperscript As Integer
0012Dim iSection As Integer
0013Dim iFootNoteID As Integer
0014Dim strPrintNote As String
0015Dim No_FN As String
0016Dim Note_Archive_ID As Long
0017Dim Note_Archive_Timestamp As Long
0018Dim Time_Called As Long
0019Dim Timestamp_Temp As Long
0020Dim i As Long
0021Dim TheWord As String
0022Dim rsNoteID As Recordset
0023Time_Called = Now() * 1000
0024'Read Notes_Archive records
0025If IsMissing(Note_ID) Then
0026 'Select all Notes_Archive
0027 strControlQuery = "SELECT Notes_Archive.* FROM Notes_Archive ORDER BY Notes_Archive.ID, Notes_Archive.Timestamp;"
0028Else
0029 If IsMissing(Note_Timestamp) Then
0030 'Select all Notes_Archive for this Note
0031 strControlQuery = "SELECT Notes_Archive.* FROM Notes_Archive WHERE Notes_Archive.ID = " & Note_ID & " ORDER BY Notes_Archive.Timestamp;"
0032 Else
0033 'Select only the Notes_Archive for this Note and Timestamp
0034 strControlQuery = "SELECT Notes_Archive.* FROM Notes_Archive WHERE Notes_Archive.ID = " & Note_ID & " AND Notes_Archive.Timestamp = " & Note_Timestamp & ";"
0035 End If
0036End If
0037Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0038rsTableToRead.MoveFirst
0039'Regenerate the Note Links
0040Do While Not rsTableToRead.EOF
0041 Note_Archive_ID = rsTableToRead.Fields(0)
0042 Note_Archive_Timestamp = rsTableToRead.Fields(11)
0043 'Ready the Note Links Archive
0044 DoCmd.RunSQL ("DELETE Note_Links_Archived.* FROM Note_Links_Archived WHERE Note_1 = " & Note_Archive_ID & "AND Note_1_Timestamp = " & Note_Archive_Timestamp & ";")
0045 strControlQuery = "SELECT Note_Links_Archived.* FROM Note_Links_Archived WHERE Note_1 = " & Note_Archive_ID & "AND Note_1_Timestamp = " & Note_Archive_Timestamp & ";"
0046 Set rsNotesLinks = CurrentDb.OpenRecordset(strControlQuery)
0047 strLine = rsTableToRead.Fields(2)
0048 strLine = ReplaceCode(strLine, Chr(13) & Chr(10), "<BR>")
0049 x = 1
0050 z = 1
0051 iSuperscript = 1
0052 x = InStr(x, strLine, "++")
0053 iSection = 0
0054 Do While x > 0
0055 'Ignore In-sheet Footnotes
0056 No_FN = "No"
0057 Do Until No_FN = "Yes"
0058 If x > 0 Then
0059 If Mid(strLine, x + 2, 2) = "FN" Then
0060 x = x + 1
0061 x = InStr(x, strLine, "++")
0062 If x > 0 Then
0063 x = x + 1
0064 x = InStr(x, strLine, "++")
0065 iSuperscript = iSuperscript + 1
0066 End If
0067 Else
0068 No_FN = "Yes"
0069 End If
0070 Else
0071 No_FN = "Yes"
0072 End If
0073 Loop
0074 If x > 0 Then
0075 Y = InStr(x + 1, strLine, "++")
0076 If Mid(strLine, x + 2, 2) = "NP" Then
0077 If InStr(Mid(strLine, x + 4, Y - x - 4), "#") > 0 Then
0078 iFootNoteID = Left(Mid(strLine, x + 4, Y - x - 4), InStr(Mid(strLine, x + 4, Y - x - 4), "#") - 1)
0079 Else
0080 If IsNumeric(Mid(strLine, x + 4, Y - x - 4)) Then
0081 iFootNoteID = Mid(strLine, x + 4, Y - x - 4)
0082 Else
0083 iFootNoteID = 0
0084 End If
0085 End If
0086 strPrintNote = "No"
0087 Else
0088 If Y = x + 1 Then
0089 'Check this is the "++++" case where we have to look up the reference
0090 If Mid(strLine, x, 4) = "++++" Then
0091 'Find the key-word(s)
0092 If x > 1 Then
0093 If Mid(strLine, x - 1, 1) = " " Then
0094 i = FindWord(strLine, x - 1, "]")
0095 TheWord = Mid(strLine, i, x - 1 - i)
0096 Else
0097 i = FindWord(strLine, x, "]")
0098 TheWord = Mid(strLine, i, x - i)
0099 End If
0100 End If
0101 If Right(TheWord, 1) = "]" Then
0102 TheWord = Mid(TheWord, 2, Len(TheWord) - 2)
0103 End If
0104 'Find the Note ID. NB uses the Note_Alternates table!
0105 Set rsNoteID = CurrentDb.OpenRecordset("SELECT Notes.ID FROM Note_Alternates INNER JOIN Notes ON Note_Alternates.Item_Title = Notes.Item_Title WHERE (((Note_Alternates.Item_Alt_Title)=""" & TheWord & """));")
0106 If rsNoteID.EOF Then
0107 strPrintNote = "1256" 'The "dud links" Note!
0108 Else
0109 rsNoteID.MoveFirst
0110 strPrintNote = rsNoteID.Fields(0)
0111 End If
0112 Set rsNoteID = Nothing
0113 strLine = Left(strLine, x + 1) & strPrintNote & Mid(strLine, x + 2)
0114 Y = Y + 1 + Len(strPrintNote)
0115 End If
0116 Else
0117 strPrintNote = Mid(strLine, x + 2, Y - x - 2)
0118 End If
0119 If InStr(strPrintNote, "#") > 0 Then
0120 iFootNoteID = Left(strPrintNote, InStr(strPrintNote, "#") - 1)
0121 Else
0122 If IsNumeric(Mid(strLine, x + 2, Y - x - 2)) Then
0123 iFootNoteID = Mid(strLine, x + 2, Y - x - 2)
0124 Else
0125 iFootNoteID = 0
0126 End If
0127 End If
0128 strPrintNote = "Yes"
0129 End If
0130 rsNotesLinks.AddNew
0131 rsNotesLinks!Note_1 = Note_Archive_ID
0132 If x > z Then
0133 Do While z < x
0134 z_Saved = z
0135 z = InStr(z + 20, strLine, "<BR>")
0136 If z = 0 Then
0137 z = 10000000
0138 End If
0139 iSection = iSection + 1
0140 Loop
0141 If z > 0 Then
0142 z = z_Saved
0143 iSection = iSection - 1
0144 End If
0145 End If
0146 rsNotesLinks!Note_1_Timestamp = Note_Archive_Timestamp
0147 rsNotesLinks!Note_1_Ref = iSection
0148 rsNotesLinks!Note_1_FN_ID = iSuperscript
0149 rsNotesLinks!Note_2 = iFootNoteID
0150 rsNotesLinks!Update_Timestamp = Time_Called
0151 rsNotesLinks![Print_Note] = strPrintNote
0152 'Find the Timestamp of the linked Note
0153 strControlQuery = "SELECT Max(Notes_Archive.[Timestamp]) FROM Notes_Archive WHERE Notes_Archive.ID = " & iFootNoteID & " AND Notes_Archive.[Timestamp] <=" & Note_Archive_Timestamp & ";"
0154 Set rsLatestTimestamp = CurrentDb.OpenRecordset(strControlQuery)
0155 If rsLatestTimestamp.EOF Then
0156 Timestamp_Temp = 0
0157 Else
0158 If rsLatestTimestamp.Fields(0) & "" = "" Then
0159 Timestamp_Temp = 0
0160 Else
0161 Timestamp_Temp = rsLatestTimestamp.Fields(0)
0162 End If
0163 End If
0164 'Can't find ... so make the best of it ...
0165 If Timestamp_Temp = 0 Then
0166 strControlQuery = "SELECT Min(Notes_Archive.[Timestamp]) FROM Notes_Archive WHERE Notes_Archive.ID = " & iFootNoteID & " AND Notes_Archive.[Timestamp] >=" & Note_Archive_Timestamp & ";"
0167 Set rsLatestTimestamp = CurrentDb.OpenRecordset(strControlQuery)
0168 If rsLatestTimestamp.EOF Then
0169 Timestamp_Temp = 0
0170 Else
0171 If rsLatestTimestamp.Fields(0) & "" = "" Then
0172 Timestamp_Temp = 0
0173 Else
0174 Timestamp_Temp = rsLatestTimestamp.Fields(0)
0175 End If
0176 End If
0177 End If
0178 rsNotesLinks!Note_2_Timestamp = Timestamp_Temp
0179 rsNotesLinks.Update
0180 x = InStr(Y + 1, strLine, "++")
0181 iSuperscript = iSuperscript + 1
0182 End If
0183 Loop
0184 rsTableToRead.MoveNext
0185Loop
0186Set rsTableToRead = Nothing
0187Set rsNotesLinks = Nothing
0188Set rsLatestTimestamp = Nothing
0189End Function

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


Source Code of: Spider_WebLinks_Tester_Brief_Page_Gen
Procedure Type: Public Sub
Module: Spider
Lines of Code: 218
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Spider_WebLinks_Tester_Brief_Page_Gen()
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 m As Integer
0009Dim FileName As String
0010Dim FileName_Root As String
0011Dim ifields As Integer
0012Dim strControlQuery As String
0013Dim rsFooterControl As Recordset
0014Dim x As String
0015Dim Link_Narr As String
0016Dim File_Sub As Integer
0017Dim strFile_Sub As String
0018Dim strJump_Table As String
0019strOutputFolder = TheoWebsiteRoot & "\Test\"
0020 Set rsTableControl2 = CurrentDb.OpenRecordset("Spider_Weblink_Fix_Check_Consolidated")
0021DoEvents
0022rsTableControl2.MoveLast
0023DoEvents
0024FileName_Root = "WebLinks_Tester_Brief"
0025'Create the jump table ...
0026ifields = rsTableControl2.RecordCount
0027ifields = ifields / 500
0028If ifields * 500 < rsTableControl2.RecordCount Then
0029 ifields = ifields + 1
0030End If
0031rsTableControl2.MoveFirst
0032strJump_Table = "<TABLE class = ""Bridge"" WIDTH=1200>"
0033strJump_Table = strJump_Table & "<tr>"
0034For i = 1 To ifields
0035 If i = 1 Then
0036 strFile_Sub = ""
0037 Else
0038 strFile_Sub = "_" & i - 1
0039 End If
0040 strJump_Table = strJump_Table & "<th><a href=""" & FileName_Root & strFile_Sub & ".htm"">" & i & "</a></th>"
0041Next i
0042strJump_Table = strJump_Table & "</tr></TABLE>"
0043ifields = rsTableControl2.Fields.Count
0044Set fsoTextFile2 = New FileSystemObject
0045m = 600
0046File_Sub = 0
0047Do While Not rsTableControl2.EOF
0048 If m > 499 Then
0049 m = 0
0050 'Close off previous file ...
0051 If File_Sub > 0 Then
0052 'Footer
0053 strLine = "<tr class=""BridgeCenter""><td class=""BridgeCenter"">Dummy</td><td class=""BridgeCenter"">xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx</td><td>xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx</td><td class=""BridgeCenter"">xxx</td><td class=""BridgeCenter"">xxx</td><td class=""BridgeCenter"">xxxxxxxxxxxxxxx</td><td class=""BridgeCenter"">xxx</td><td class=""BridgeCenter"">xxx</td><td class=""BridgeCenter"">xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx</td></tr>"
0054 strLine = strLine & "</TABLE><BR>"
0055 tsTextFile.WriteLine strLine
0056 'Add link to previous & next file ...
0057 If File_Sub > 1 Then
0058 If File_Sub = 2 Then
0059 strFile_Sub = ""
0060 Else
0061 strFile_Sub = "_" & File_Sub - 2
0062 End If
0063 strLine = "<h3><a href=""" & FileName_Root & strFile_Sub & ".htm"">" & "Previous File</a> : "
0064 Else
0065 strLine = "<h3>"
0066 End If
0067 strFile_Sub = "_" & File_Sub
0068 strLine = strLine & "<a href=""" & FileName_Root & strFile_Sub & ".htm"">" & "Next File</a></h3>"
0069 tsTextFile.WriteLine strLine
0070 'Page Footer
0071 strLine = ""
0072 strControlTable = "WebLinkCheck_Ctrl"
0073 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;"
0074 Set rsFooterControl = CurrentDb.OpenRecordset(strControlQuery)
0075 rsFooterControl.MoveFirst
0076 Do While Not rsFooterControl.EOF
0077 strLine = strLine & rsFooterControl.Fields(0)
0078 OK = Replace_Timestamp(strLine)
0079 rsFooterControl.MoveNext
0080 Loop
0081 tsTextFile.WriteLine strLine
0082 OK = CopyToTransfer(strOutputFolder, FileName)
0083 End If
0084 'Output a new file + headers
0085 If File_Sub = 0 Then
0086 strFile_Sub = ""
0087 Else
0088 strFile_Sub = "_" & File_Sub
0089 End If
0090 FileName = FileName_Root & strFile_Sub & ".htm"
0091 strOutputFile = strOutputFolder & FileName
0092 Set tsTextFile = fsoTextFile2.CreateTextFile(strOutputFile, True, True)
0093 strLine = "<!DOCTYPE html><HTML lang=""en"">"
0094 tsTextFile.WriteLine strLine
0095 strLine = "<HEAD><meta charset=""utf-8"">"
0096 tsTextFile.WriteLine strLine
0097 strLine = "<TITLE>Theo Todman's Consolidated Web-Links Test Webpage</TITLE>"
0098 tsTextFile.WriteLine strLine
0099 strLine = "<link href=""../TheosStyle.css"" rel=""stylesheet"" type=""text/css""><link rel=""shortcut icon"" href=""../TT_ICO.png"" /></HEAD><BODY>"
0100 tsTextFile.WriteLine strLine
0101 strLine = "<H1>Theo Todman's Consolidated Web-Links Test Webpage</H1><CENTER>"
0102 tsTextFile.WriteLine strLine
0103 strLine = "<p>The table of links below lists a consolidation of all the external links from my website and an indication of whether they still work. The main table is preceeded by a Jump Table of the sub-pages into which this page is now split. All this is still under development. </p>"
0104 tsTextFile.WriteLine strLine
0105 'Add the files jump table
0106 tsTextFile.WriteLine strJump_Table
0107 File_Sub = File_Sub + 1
0108 strLine = "<H2>Page " & File_Sub & "</H2>"
0109 tsTextFile.WriteLine strLine
0110 'Headings
0111 If Not rsTableControl2.EOF Then
0112 strLine = "<TABLE class = ""ReadingList"" WIDTH=1400>"
0113 tsTextFile.WriteLine strLine
0114 End If
0115 strLine = "<TR>"
0116 tsTextFile.WriteLine strLine
0117 'Headers
0118 j = 0
0119 Do While j < ifields
0120 strLine = "<TH class = ""BridgeCenter"">" & rsTableControl2.Fields(j).Name & "</TH>"
0121 tsTextFile.WriteLine strLine
0122 j = j + 1
0123 Loop
0124 strLine = "</TR>"
0125 tsTextFile.WriteLine strLine
0126 End If
0127 'Rows
0128 m = m + 1
0129 strLine = "<TR>"
0130 tsTextFile.WriteLine strLine
0131 j = 0
0132 Do While j < ifields
0133 x = rsTableControl2.Fields(j) & ""
0134 Select Case j
0135 Case 0
0136 strLine = "<TD Class = ""BridgeCenter"">"
0137 Case 1
0138 Link_Narr = x
0139 If rsTableControl2.Fields(2) & "" = "" Then
0140 strLine = "<TD Class = ""BridgeLeft"" colspan=2>"
0141 If Len(Link_Narr) > 100 Then
0142 Link_Narr = Left(x, 95) & " ..."
0143 End If
0144 Else
0145 strLine = "<TD Class = ""BridgeLeft"">"
0146 If Len(Link_Narr) > 50 Then
0147 Link_Narr = Left(x, 45) & " ..."
0148 End If
0149 End If
0150 x = "<a href=""" & x & """>" & Link_Narr & "</a>"
0151 Case 2
0152 Link_Narr = x
0153 If Link_Narr <> "" Then
0154 strLine = "<TD Class = ""BridgeLeft"">"
0155 If Len(Link_Narr) > 50 Then
0156 Link_Narr = Left(x, 45) & " ..."
0157 End If
0158 x = "<a href=""" & x & """>" & Link_Narr & "</a>"
0159 Else
0160 strLine = ""
0161 End If
0162 Case ifields - 3
0163 strLine = "<TD Class = ""BridgeCenter"">"
0164 x = Left(x, 10)
0165 Case ifields - 2
0166 strLine = "<TD Class = ""BridgeCenter"">"
0167 Case Else
0168 strLine = "<TD Class = ""BridgeLeft"">"
0169 If x = "" Then
0170 x = "&nbsp;"
0171 End If
0172 If rsTableControl2.Fields(j).Name = "Defunct ?" Then
0173 strLine = "<TD Class = ""BridgeCenter"">"
0174 If x = "No" Then
0175 x = "&nbsp;"
0176 End If
0177 End If
0178 End Select
0179 strLine = strLine & x
0180 If strLine <> "" Then
0181 strLine = strLine & "</TD>"
0182 tsTextFile.WriteLine strLine
0183 End If
0184 j = j + 1
0185 Loop
0186 strLine = "</TR>"
0187 tsTextFile.WriteLine strLine
0188 rsTableControl2.MoveNext
0189Loop
0190'Footer
0191strLine = "<tr class=""BridgeCenter""><td class=""BridgeCenter"">Dummy</td><td class=""BridgeCenter"">xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx</td><td>xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx</td><td class=""BridgeCenter"">xxx</td><td class=""BridgeCenter"">xxx</td><td class=""BridgeCenter"">xxxxxxxxxxxxxxx</td><td class=""BridgeCenter"">xxx</td><td class=""BridgeCenter"">xxx</td><td class=""BridgeCenter"">xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx</td></tr>"
0192strLine = strLine & "</TABLE><BR>"
0193tsTextFile.WriteLine strLine
0194'Add link to previous ...
0195If File_Sub > 1 Then
0196 If File_Sub = 2 Then
0197 strFile_Sub = ""
0198 Else
0199 strFile_Sub = "_" & File_Sub - 2
0200 End If
0201 strLine = "<h3><a href=""" & FileName_Root & strFile_Sub & ".htm"">" & "Previous File</a></h3>"
0202 tsTextFile.WriteLine strLine
0203End If
0204'Page Footer
0205strLine = ""
0206strControlTable = "WebLinkCheck_Ctrl"
0207 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;"
0208Set rsFooterControl = CurrentDb.OpenRecordset(strControlQuery)
0209rsFooterControl.MoveFirst
0210Do While Not rsFooterControl.EOF
0211 strLine = strLine & rsFooterControl.Fields(0)
0212 OK = Replace_Timestamp(strLine)
0213 rsFooterControl.MoveNext
0214Loop
0215tsTextFile.WriteLine strLine
0216 OK = CopyToTransfer(strOutputFolder, FileName)
0217Set tsTextFile = Nothing
0218End Sub

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


Source Code of: WebpageGenBookCitingsPage
Procedure Type: Public Sub
Module: Webpage_Generators
Lines of Code: 13

Line-No. / Ref.Code Line
0001Public Sub WebpageGenBookCitingsPage()
0002 strControlTable = "Book_Citings_Page_List"
0003strOutputFileShort = "BookCitings"
0004strOutputFolder = TheoWebsiteRoot & "\"
0005strOutputFile = strOutputFolder & strOutputFileShort
0006 strDataQuery = "Book_Citings_Page_List"
0007strSplitTable = "No"
0008strControlBreakType = "Initial"
0009strControlBreakType2 = ""
0010Main_Header = "No"
0011RootCreated = ""
0012 CreatePapersWebTable
0013End Sub

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


Source Code of: WebpageGenNotePapersLinks
Procedure Type: Public Sub
Module: Webpage_Generators
Lines of Code: 13

Line-No. / Ref.Code Line
0001Public Sub WebpageGenNotePapersLinks()
0002 strControlTable = "Note_Paper_Links"
0003strOutputFileShort = "NotePaperLinks"
0004strOutputFolder = TheoWebsiteRoot & "\"
0005strOutputFile = strOutputFolder & strOutputFileShort
0006 strDataQuery = "Note_Paper_Links_List"
0007strSplitTable = "Yes"
0008strControlBreakType = "Initial"
0009strControlBreakType2 = ""
0010Main_Header = "Yes"
0011RootCreated = ""
0012 CreatePapersWebTable
0013End Sub

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


© Theo Todman, June 2007 - March 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