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 13 (8 items)

cmdBible_ClickcmdPIDLookup_ClickAddReading_ListLanguage_Animadversion_Reference_List
ZapFilesCreate_URL_Key1Create_URL_Key2CreateConcatenatedNoteGroupWebPages

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

Go to top of page



Source Code of: AddReading_List
Procedure Type: Public Function
Module: New Code
Lines of Code: 137
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function AddReading_List(Note_Title, tsTextFile As TextStream, Optional DirectoryLevel, Optional PrintQualityTitle)
0002Dim rsNotesLinks As Recordset
0003Dim strControlQuery As String
0004Dim rsTableControl2 As Recordset
0005Dim strLine As String
0006Dim x As Long
0007Dim Y As String
0008Dim z As Long
0009Dim strLink As String
0010Dim BackLevel As String
0011Dim strAbstractQualityQuery As String
0012Dim rsAbstractQuality As Recordset
0013Dim strIcon As String
0014Dim strAlt As String
0015Dim strTitle As String
0016Y = Replace(Note_Title, """", """""")
0017 strControlQuery = "SELECT [Sub-Topics].[Sub-Topic] FROM [Sub-Topics] WHERE ((([Sub-Topics].[Sub-Topic])=""" & Y & """));"
0018Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0019If rsTableControl2.EOF Then
0020 strControlQuery = "Citations_List_Short"
0021Else
0022 strControlQuery = "Citations_List"
0023 'Note: this cascade of queries selects (inter alia) on the priority of the papers and books (based on their depth in the Note hierarchy), and low priority items are ignored ... so, if expected books / papers don't appear, this may be why!
0024End If
0025Set rsTableControl2 = Nothing
0026If IsMissing(DirectoryLevel) Then
0027 BackLevel = "../../../"
0028Else
0029 BackLevel = "../../"
0030End If
0031Set rsNotesLinks = CurrentDb.OpenRecordset(strControlQuery)
0032If Not rsNotesLinks.EOF Then
0033 ' ... Header
0034 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = ""Reading_List"") And ((Website_Control.Section) = ""Header"")) ORDER BY Website_Control.Line;"
0035 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0036 rsTableControl2.MoveFirst
0037 Do While Not rsTableControl2.EOF
0038 strLine = rsTableControl2.Fields(0) & ""
0039 tsTextFile.WriteLine strLine
0040 rsTableControl2.MoveNext
0041 Loop
0042 ' ... Rows .. Headings
0043 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = ""Reading_List"") And ((Website_Control.Section) = ""Rows"")) ORDER BY Website_Control.Line;"
0044 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0045 rsTableControl2.MoveFirst
0046 rsNotesLinks.MoveFirst
0047 Do While Not rsTableControl2.EOF
0048 strLine = rsTableControl2.Fields(0) & ""
0049 x = InStr(1, strLine, "**Column")
0050 If x > 0 Then
0051 z = Val(Mid(strLine, x + 8, 2))
0052 Y = "<B>" & rsNotesLinks.Fields(z - 1).Name & "</B>"
0053 If Y = "" Then
0054 Y = "."
0055 End If
0056 strLine = Left(strLine, x - 1) & Y & Mid(strLine, x + 12, Len(strLine))
0057 tsTextFile.WriteLine strLine
0058 End If
0059 rsTableControl2.MoveNext
0060 Loop
0061 'Rows
0062 rsTableControl2.MoveFirst
0063 Do While Not rsNotesLinks.EOF
0064 Do While Not rsTableControl2.EOF
0065 strLine = rsTableControl2.Fields(0) & ""
0066 x = InStr(1, strLine, "**Column")
0067 If x > 0 Then
0068 z = Val(Mid(strLine, x + 8, 2))
0069 Y = rsNotesLinks.Fields(z - 1).Value & ""
0070 'Hyperlink
0071 If z = 3 Then
0072 strAbstractQualityQuery = ""
0073 If Left(Y, 4) = "Book" Then
0074 strLink = "BookSummaries/BookSummary_" & Mid(Trim(rsNotesLinks.Fields(7).Value + 100000), 2, 2) & "/BookPaperAbstracts/BookPaperAbstracts_" & rsNotesLinks.Fields(7).Value & ".htm"">"
0075 If rsNotesLinks.Fields(9).Value = "No" Then
0076 Else
0077 strAbstractQualityQuery = "SELECT ""<img src=""""" & BackLevel & """ & [Icon] & """""" alt="""""" & [Display_Text] & "" Abstract"""">"" AS [Image] FROM Quality_Markers INNER JOIN Books ON Quality_Markers.Quality = Books.Abstract_Quality WHERE (((Books.ID1)=" & rsNotesLinks.Fields(7) & "));"
0078 Set rsAbstractQuality = CurrentDb.OpenRecordset(strAbstractQualityQuery)
0079 If Not rsAbstractQuality.EOF Then
0080 rsAbstractQuality.MoveFirst
0081 strAbstractQualityQuery = rsAbstractQuality.Fields(0).Value & ""
0082 Else
0083 strAbstractQualityQuery = ""
0084 End If
0085 Set rsAbstractQuality = Nothing
0086 End If
0087 Else
0088 If rsNotesLinks.Fields(10).Value = "No" Then
0089 strLink = "PaperSummaries/PaperSummary_" & Mid(Trim(rsNotesLinks.Fields(8).Value + 100000), 2, 2) & "/PaperSummary_" & rsNotesLinks.Fields(8).Value & ".htm"">"
0090 Else
0091 strAbstractQualityQuery = "SELECT Quality_Markers.Display_Text, Quality_Markers.Icon, Quality_Markers.Annotations FROM Quality_Markers INNER JOIN Papers ON Quality_Markers.Quality = Papers.Abstract_Quality WHERE (((Papers.ID)=" & rsNotesLinks.Fields(8) & "));"
0092 Set rsAbstractQuality = CurrentDb.OpenRecordset(strAbstractQualityQuery)
0093 If Not rsAbstractQuality.EOF Then
0094 rsAbstractQuality.MoveFirst
0095 strAlt = rsAbstractQuality.Fields(0).Value & ""
0096 strIcon = rsAbstractQuality.Fields(1).Value & ""
0097 strTitle = rsAbstractQuality.Fields(2).Value & ""
0098 strAbstractQualityQuery = "<img src=""" & BackLevel & strIcon & """alt=""" & strAlt & " Abstract"" Title=""" & strTitle & """>"
0099 If IsMissing(PrintQualityTitle) Then
0100 Else
0101 If strTitle <> "" Then
0102 strAbstractQualityQuery = strAbstractQualityQuery & "<br> (" & strTitle & ")"
0103 End If
0104 End If
0105 Else
0106 strAbstractQualityQuery = ""
0107 End If
0108 Set rsAbstractQuality = Nothing
0109 strLink = "Abstracts/Abstract_" & Mid(Trim(rsNotesLinks.Fields(8).Value + 100000), 2, 2) & "/Abstract_" & rsNotesLinks.Fields(8).Value & ".htm"">"
0110 End If
0111 End If
0112 Y = "<A HREF=""" & BackLevel & strLink & Y & "</A> " & strAbstractQualityQuery
0113 End If
0114 If Y = "" Then
0115 Y = "&nbsp;"
0116 End If
0117 strLine = Left(strLine, x - 1) & Y & Mid(strLine, x + 12, Len(strLine))
0118 tsTextFile.WriteLine strLine
0119 Else
0120 tsTextFile.WriteLine strLine
0121 End If
0122 rsTableControl2.MoveNext
0123 Loop
0124 rsNotesLinks.MoveNext
0125 rsTableControl2.MoveFirst
0126 Loop
0127 ' ... Footer
0128 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = ""Reading_List"") And ((Website_Control.Section) = ""Footer"")) ORDER BY Website_Control.Line;"
0129 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0130 rsTableControl2.MoveFirst
0131 Do While Not rsTableControl2.EOF
0132 strLine = rsTableControl2.Fields(0) & ""
0133 tsTextFile.WriteLine strLine
0134 rsTableControl2.MoveNext
0135 Loop
0136End If
0137End Function

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


Source Code of: cmdBible_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 8

Line-No. / Ref.Code Line
0001Private Sub cmdBible_Click()
0002 DoCmd.Close acQuery, "Bible_Reading_Progress"
0003 DoCmd.Close acTable, "Koran"
0004 DoCmd.Close acQuery, "Bible_Progress_Updt"
0005 DoCmd.OpenQuery ("Bible_Reading_Progress")
0006'DoCmd.OpenTable ("Koran")
0007 DoCmd.OpenQuery ("Bible_Progress_Updt")
0008End Sub

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


Source Code of: cmdPIDLookup_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 4

Line-No. / Ref.Code Line
0001Private Sub cmdPIDLookup_Click()
0002 DoCmd.Close acQuery, "PID_Note_ID_Lookup"
0003 DoCmd.OpenQuery ("PID_Note_ID_Lookup")
0004End Sub

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


Source Code of: Create_URL_Key1
Procedure Type: Public Sub
Module: Spider
Lines of Code: 25
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Create_URL_Key1()
0002Dim rst_Core As Recordset
0003Dim strQuery As String
0004Dim In_URL As String
0005Dim Core_URL As String
0006Debug.Print Now() & " - Create_URL_Key1 Started"
0007 strQuery = "SELECT Hits_Bots.URL, Hits_Bots.URL_Key FROM Hits_Bots ORDER BY Hits_Bots.URL;"
0008Set rst_Core = CurrentDb.OpenRecordset(strQuery)
0009rst_Core.MoveFirst
0010Do Until rst_Core.EOF
0011 In_URL = rst_Core.Fields(0)
0012 Core_URL = Core_URL_Gen(In_URL)
0013 'If this fails, run DAO.DBEngine.SetOption dbmaxlocksperfile,1000000 in the immediate window below
0014 rst_Core.Edit
0015 If Core_URL & "" <> "" Then
0016 rst_Core.Fields(1) = Core_URL
0017 Else
0018 rst_Core.Fields(1) = In_URL
0019 End If
0020 rst_Core.Update
0021 rst_Core.MoveNext
0022Loop
0023Set rst_Core = Nothing
0024Debug.Print Now() & " - Create_URL_Key1 Completed"
0025End Sub

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


Source Code of: Create_URL_Key2
Procedure Type: Public Sub
Module: Spider
Lines of Code: 43
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Create_URL_Key2()
0002Dim rst_Core_URLs As Recordset
0003Dim rst_Hits_Bots As Recordset
0004Dim strQuery As String
0005Dim In_URL As String
0006Dim Core_URL As String
0007Dim URL_Key As String
0008Dim Institution As String
0009Dim i As Integer
0010Dim j As Long
0011Debug.Print Now() & " - Create_URL_Key2 Started"
0012 strQuery = "SELECT Core_URLs.* FROM Core_URLs;"
0013Set rst_Core_URLs = CurrentDb.OpenRecordset(strQuery)
0014rst_Core_URLs.MoveFirst
0015Do Until rst_Core_URLs.EOF
0016 Core_URL = rst_Core_URLs.Fields(0)
0017 i = Len(Core_URL)
0018 Institution = rst_Core_URLs.Fields(1)
0019 j = 0
0020 strQuery = "SELECT Hits_Bots.URL, Hits_Bots.URL_Key FROM Hits_Bots ORDER BY Hits_Bots.URL;"
0021 Set rst_Hits_Bots = CurrentDb.OpenRecordset(strQuery)
0022 rst_Hits_Bots.MoveFirst
0023 Do Until rst_Hits_Bots.EOF
0024 In_URL = rst_Hits_Bots.Fields(0)
0025 URL_Key = rst_Hits_Bots.Fields(1) & ""
0026 If URL_Key = "" Or URL_Key = In_URL Then
0027 If Left(In_URL, i) = Core_URL Then
0028 rst_Hits_Bots.Edit
0029 rst_Hits_Bots.Fields(1) = Institution
0030 rst_Hits_Bots.Update
0031 j = j + 1
0032 End If
0033 End If
0034 rst_Hits_Bots.MoveNext
0035 Loop
0036 'Debug.Print Now() & " - Create_URL_Key2: Core_URL = " & Core_URL & " Updates = " & j
0037 Set rst_Hits_Bots = Nothing
0038 rst_Core_URLs.MoveNext
0039Loop
0040Set rst_Core_URLs = Nothing
0041Set rst_Hits_Bots = Nothing
0042Debug.Print Now() & " - Create_URL_Key2 Completed"
0043End Sub

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


Source Code of: CreateConcatenatedNoteGroupWebPages
Procedure Type: Public Sub
Module: New Code
Lines of Code: 222
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub CreateConcatenatedNoteGroupWebPages()
0002'This is a new module to generate the pages that list all the Notes (in Title sequence) in a selected Notes-Group
0003'It was based on Sub CreateBookPaperAbstractsWebPages
0004'Earlier versions used to print the Note text, but the resulting pages got far too large.
0005Dim fsoTextFile As FileSystemObject
0006Dim rsTableToRead As Recordset
0007Dim rsTableControl As Recordset
0008Dim rsTableControl2 As Recordset
0009Dim rsNotesLinks As Recordset
0010Dim strControlQuery As String
0011Dim strLine As String
0012Dim iTableColumns As Integer
0013Dim x As Long
0014Dim Y As String
0015Dim i As Long
0016Dim strFileSuffix As String
0017Dim strFileBody As String
0018Dim StartTime As Double
0019Dim strText As String
0020Dim iDepth As Integer
0021Dim strNoteGroup As String
0022Dim iNotes_Title_Index As Integer
0023Dim strNotesTitle_Saved As String
0024Dim FootNoteTimestamp As Single
0025Dim strDirectory As String
0026Dim TextColour As Integer
0027Dim RunTime As Single
0028Dim strControlTable_Saved As String
0029Dim Time_Stamp As String
0030'Update the Notes_Group "Last Concatenated" Timestamp
0031 Set rsTableToRead = CurrentDb.OpenRecordset("Select Latest_Concatenation, Time_To_Concatenate, Narrative FROM Note_Groups WHERE ID = " & Notes_Group_ID & ";")
0032rsTableToRead.MoveFirst
0033Notes_Group_Narrative = rsTableToRead.Fields(2) & ""
0034rsTableToRead.Edit
0035rsTableToRead.Fields(0) = Now()
0036rsTableToRead.Update
0037Set fsoTextFile = New FileSystemObject
0038strFolder = strOutputFolder
0039StartTime = Now()
0040iDepth = 1
0041'Read the data
0042Set rsTableToRead = CurrentDb.OpenRecordset(strDataQuery)
0043'Find the Note Group
0044If Not rsTableToRead.EOF Then
0045 rsTableToRead.MoveFirst
0046 strNoteGroup = rsTableToRead.Fields(0) & ""
0047End If
0048strFileSuffix = strOutputFileShort
0049If Notes_Group_ID = 10 Then
0050 strFileBody = "Secure_Jen/"
0051Else
0052 strFileBody = "Notes/"
0053End If
0054'Create File
0055Set tsTextFile = fsoTextFile.CreateTextFile(strOutputFolder & strFileBody & "\" & strFileSuffix & ".htm", True, True)
0056'Page Header
0057strControlTable_Saved = strControlTable
0058 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Header"")) ORDER BY Website_Control.Line;"
0059Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0060rsTableControl.MoveFirst
0061Do While Not rsTableControl.EOF
0062 strLine = rsTableControl.Fields(0) & ""
0063 i = InStr(strLine, "**TOPIC**")
0064 If i > 0 Then
0065 strLine = Left(strLine, i - 1) & strNoteGroup & Mid(strLine, i + Len("**TOPIC**"))
0066 End If
0067 tsTextFile.WriteLine strLine
0068 rsTableControl.MoveNext
0069Loop
0070'Output Jump Table
0071strControlTable = "Jump_Table_Titles_Notes"
0072 strTargetFileShort = "Notes"
0073 strDataQuery = "Notes_Jump"
0074strSplitTable = "Yes"
0075Notes_Recent = 0
0076 JumpTableTitles ("Concatenated")
0077'Output the Notes (links + stats)
0078If Not rsTableToRead.EOF Then
0079 rsTableToRead.MoveFirst
0080 iTableColumns = rsTableToRead.Fields.Count
0081 Do Until rsTableToRead.EOF
0082 'Add name for internal hyperlink
0083 strLine = "<a name=""InternalHyperlink_Note_" & Trim(rsTableToRead.Fields(2)) & """></A>"
0084 tsTextFile.WriteLine strLine
0085 'Note Headers
0086 strText = ""
0087 TextColour = 0
0088 strLine = "<HR class = ""Bold"">"
0089 tsTextFile.WriteLine strLine
0090 For i = 3 To iTableColumns - 2
0091 If rsTableToRead.Fields(i) & "" <> "" Then
0092 strLine = "<p class = ""Left""><b><u>" & rsTableToRead.Fields(i).Name & "</b></u>: " & rsTableToRead.Fields(i) & "</p>"
0093 tsTextFile.WriteLine strLine
0094 End If
0095 Next i
0096 'Add count of reading list
0097 'Clear the Notes usage table
0098 DoCmd.RunSQL ("DELETE Note_Usage_Temp.* FROM Note_Usage_Temp;")
0099 'Prepopulate with the main note
0100 strLine = "SELECT Note_Usage_Temp.* FROM Note_Usage_Temp;"
0101 Set rsTableControl = CurrentDb.OpenRecordset(strLine)
0102 strLine = ""
0103 rsTableControl.AddNew
0104 rsTableControl.Fields(0) = rsTableToRead.Fields(2).Value
0105 rsTableControl.Fields(1) = "Main Text"
0106 rsTableControl.Fields(4) = iDepth
0107 rsTableControl.Update
0108 Set rsTableControl = CurrentDb.OpenRecordset("Citations_Count")
0109 If Not rsTableControl.EOF Then
0110 rsTableControl.MoveFirst
0111 strLine = "<p class = ""Left""><b><u>Citation Counts</b></u>:</p><UL TYPE=""DISC"">"
0112 Do While Not rsTableControl.EOF
0113 strLine = strLine & "<LI>" & rsTableControl.Fields(0).Value & ": <B>" & rsTableControl.Fields(1).Value & "</B></li>"
0114 rsTableControl.MoveNext
0115 Loop
0116 strLine = strLine & "</UL>"
0117 End If
0118 Set rsTableControl = Nothing
0119 tsTextFile.WriteLine strLine
0120 'Used to print the Note text here!
0121 'Add the "Links to this Webpage"
0122 iNotes_Title_Index = 1
0123 strControlQuery = "SELECT Note_Links.Note_1, Note_Links.Note_1_Ref, Notes.Item_Title, Notes.Note_Group, Notes_1.Note_Group FROM (Note_Links INNER JOIN Notes ON Note_Links.Note_1 = Notes.ID) INNER JOIN Notes AS Notes_1 ON Note_Links.Note_2 = Notes_1.ID WHERE (((Note_Links.Note_2) = " & rsTableToRead.Fields(2) & ")) ORDER BY Notes.Item_Title;"
0124 Set rsNotesLinks = CurrentDb.OpenRecordset(strControlQuery)
0125 If Not rsNotesLinks.EOF Then
0126 strLine = "<HR><p class = ""Left""><b><u>Links to this page</b></u> (" & rsTableToRead.Fields(3) & ")</p>"
0127 tsTextFile.WriteLine strLine
0128 'Title-based jump table
0129 ' ... Header
0130 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = ""Jump_Table_Titles_Concatenated"") And ((Website_Control.Section) = ""Header"")) ORDER BY Website_Control.Line;"
0131 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0132 rsTableControl2.MoveFirst
0133 Do While Not rsTableControl2.EOF
0134 strLine = rsTableControl2.Fields(0) & ""
0135 tsTextFile.WriteLine strLine
0136 rsTableControl2.MoveNext
0137 Loop
0138 ' ... Rows
0139 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = ""Jump_Table_Titles"") And ((Website_Control.Section) = ""Rows"")) ORDER BY Website_Control.Line;"
0140 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0141 rsTableControl2.MoveFirst
0142 rsNotesLinks.MoveFirst
0143 Do While (Not rsTableControl2.EOF Or Not rsNotesLinks.EOF)
0144 If rsTableControl2.EOF Then
0145 rsTableControl2.MoveFirst
0146 End If
0147 strLine = rsTableControl2.Fields(0) & ""
0148 x = InStr(1, strLine, "**Column")
0149 If x > 0 Then
0150 If Not rsNotesLinks.EOF Then
0151 If rsNotesLinks.Fields(2) = strNotesTitle_Saved Then
0152 iNotes_Title_Index = iNotes_Title_Index + 1
0153 Else
0154 iNotes_Title_Index = 1
0155 strNotesTitle_Saved = rsNotesLinks.Fields(2)
0156 End If
0157 FootNoteTimestamp = 0
0158 'Determine if across secure area
0159 strDirectory = ""
0160 If rsNotesLinks.Fields(3) <> 10 Then
0161 strDirectory = "../Notes/"
0162 Else
0163 strDirectory = "../Secure_Jen/"
0164 End If
0165 Y = "<A href = """ & strDirectory & "Notes_" & Find_New_Directory(rsNotesLinks.Fields(0).Value) & "/Notes_" & rsNotesLinks.Fields(0) & IIf(FootNoteTimestamp > 0, "_" & FootNoteTimestamp, "") & ".htm" & IIf(rsNotesLinks.Fields(1) <> 0, "#" & rsNotesLinks.Fields(1), "") & """>" & rsNotesLinks.Fields(2) & IIf(iNotes_Title_Index > 1, " (" & iNotes_Title_Index & ")", "") & "</A>"
0166 Else
0167 Y = "."
0168 End If
0169 strLine = Left(strLine, x - 1) & Y & Mid(strLine, x + 10, Len(strLine))
0170 If Not rsNotesLinks.EOF Then
0171 rsNotesLinks.MoveNext
0172 End If
0173 tsTextFile.WriteLine strLine
0174 Else
0175 tsTextFile.WriteLine strLine
0176 End If
0177 rsTableControl2.MoveNext
0178 Loop
0179 ' ... Footer
0180 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = ""Jump_Table_Titles_Concatenated"") And ((Website_Control.Section) = ""Footer"")) ORDER BY Website_Control.Line;"
0181 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0182 rsTableControl2.MoveFirst
0183 Do While Not rsTableControl2.EOF
0184 strLine = rsTableControl2.Fields(0) & ""
0185 tsTextFile.WriteLine strLine
0186 rsTableControl2.MoveNext
0187 Loop
0188 End If
0189 'Next Record
0190 rsTableToRead.MoveNext
0191 Loop
0192End If
0193'Write the Footer
0194strLine = "<HR class = ""Bold"">"
0195tsTextFile.WriteLine strLine
0196 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable_Saved & """) And ((Website_Control.Section) = ""Footer"")) ORDER BY Website_Control.Line;"
0197Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0198rsTableControl.MoveFirst
0199Do While Not rsTableControl.EOF
0200 Time_Stamp = rsTableControl.Fields(0) & ""
0201 OK = Replace_Timestamp(Time_Stamp)
0202 tsTextFile.WriteLine Time_Stamp
0203 rsTableControl.MoveNext
0204Loop
0205RunTime = Round((Now() - StartTime) * 24 * 60, 1)
0206'Update the Notes_Group "Last Concatenated" Timestamp
0207 Set rsTableToRead = CurrentDb.OpenRecordset("Select Latest_Concatenation, Time_To_Concatenate FROM Note_Groups WHERE ID = " & Notes_Group_ID & ";")
0208rsTableToRead.MoveFirst
0209rsTableToRead.Edit
0210rsTableToRead.Fields(0) = Now()
0211rsTableToRead.Fields(1) = RunTime
0212rsTableToRead.Update
0213 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0214Set tsTextFile = Nothing
0215Set rsTableToRead = Nothing
0216Set rsTableControl = Nothing
0217Set rsTableControl2 = Nothing
0218Set rsNotesLinks = Nothing
0219If automatic_processing <> "Yes" Then
0220 MsgBox strOutputFile & "Concatenated Note Group Web Page """ & strNoteGroup & """ Creation Complete, in " & RunTime & " minutes.", vbOKOnly, "Create Books To Papers Links"
0221End If
0222End Sub

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


Source Code of: Language_Animadversion_Reference_List
Procedure Type: Public Function
Module: Testing
Lines of Code: 29
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Language_Animadversion_Reference_List(Language)
0002Dim rs As Recordset
0003Dim strQuery As String
0004Dim strList_Local As String
0005Dim iCount As Integer
0006Dim strLang_Saved As String
0007strList_Local = ""
0008 strQuery = "SELECT Language_Animadversions_XRef2.[Called Language], Language_Animadversions_XRef2.[Calling Language], Language_Animadversions_XRef2.ID FROM Language_Animadversions_XRef2 WHERE (((Language_Animadversions_XRef2.[Called Language]) = """ & Language & """)) ORDER BY Language_Animadversions_XRef2.[Calling Language], Language_Animadversions_XRef2.ID;"
0009Set rs = CurrentDb.OpenRecordset(strQuery)
0010strLang_Saved = ""
0011If Not rs.EOF Then
0012 rs.MoveFirst
0013 Do Until rs.EOF
0014 If strList_Local <> "" Then
0015 strList_Local = strList_Local & ", "
0016 End If
0017 If rs.Fields(1) = strLang_Saved Then
0018 iCount = iCount + 1
0019 strList_Local = strList_Local & "([" & iCount & "]++1313#" & rs.Fields(2) & "++)"
0020 Else
0021 strLang_Saved = rs.Fields(1)
0022 iCount = 1
0023 strList_Local = strList_Local & "[" & rs.Fields(1) & "]++1313#" & rs.Fields(2) & "++"
0024 End If
0025 rs.MoveNext
0026 Loop
0027End If
0028Language_Animadversion_Reference_List = strList_Local
0029End Function

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


Source Code of: ZapFiles
Procedure Type: Public Function
Module: Spider
Lines of Code: 34
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function ZapFiles(Core_Directory, Optional File_Prefix)
0002Dim fso As FileSystemObject
0003Dim Zap_File As Boolean
0004Dim DirectoryName As String
0005Dim MainFolder
0006Dim FileCollection
0007Dim File
0008Dim File_Name As String
0009Set fso = CreateObject("Scripting.FileSystemObject")
0010DirectoryName = Core_Directory
0011Set MainFolder = fso.GetFolder(DirectoryName)
0012Set FileCollection = MainFolder.Files
0013For Each File In FileCollection
0014 File_Name = File.Name
0015 If IsMissing(File_Prefix) Then
0016 Zap_File = True
0017 Else
0018 If Left(File_Name, Len(File_Prefix)) = File_Prefix Then
0019 Zap_File = True
0020 Else
0021 Zap_File = False
0022 End If
0023 End If
0024 If Zap_File = True Then
0025 File_Name = DirectoryName & "\" & File_Name
0026 If Dir(File_Name) <> "" Then
0027 Kill File_Name
0028 End If
0029 End If
0030Next
0031Set fso = Nothing
0032Set MainFolder = Nothing
0033Set FileCollection = Nothing
0034End Function

Procedures Calling This Procedure (ZapFiles) 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