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 36 (9 items)

cmdAuto_Reference_Notes_ClickcmdWebLinks_ClickcmdWebsiteMaintenanceDashboard_ClickFunctor_01
Archive_Xtab_PageStartTimerTranslate_WebrefsWebpageGenBooksRecent
WebpageGenNoteBooksLinks...

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

Go to top of page



Source Code of: Archive_Xtab_Page
Procedure Type: Public Sub
Module: Documentation
Lines of Code: 136
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Archive_Xtab_Page(Optional Recent)
0002'Create web-page of (recent) Code changes
0003Dim strOutputFolder As String
0004Dim strOutputFile As String
0005Dim strLine As String
0006Dim strHeader As String
0007Dim rsTableControl2 As Recordset
0008Dim j As Integer
0009Dim FileName As String
0010Dim FileName_Root As String
0011Dim ifields As Integer
0012Dim iFieldWidth As Integer
0013Dim Field_Width As Integer
0014Dim x As String
0015Dim strRecent As String
0016Dim strRecent_Meaning As String
0017Dim strQuery As String
0018Dim strFile_Sub As String
0019Dim strTitle As String
0020strOutputFolder = TheoWebsiteRoot & "\Documentation\"
0021If SubSystem & "" = "" Then
0022 FileName_Root = "Code_Archive"
0023Else
0024 FileName_Root = SubSystem & "_Code_Archive"
0025End If
0026If IsMissing(Recent) Then
0027 strFile_Sub = ""
0028 strTitle = ""
0029 strRecent = ""
0030 strRecent_Meaning = ""
0031 strQuery = "Code_Archive_Xtab"
0032Else
0033 strFile_Sub = "_Recent"
0034 strTitle = "Recent "
0035 strRecent = "recent "
0036 strRecent_Meaning = " ""Recent"" is within the last 12 months."
0037 strQuery = "Code_Archive_Xtab_Recent"
0038End If
0039strTitle = "Theo Todman's " & strTitle & Trim(SubSystem & " Code Changes")
0040Set rsTableControl2 = CurrentDb.OpenRecordset(strQuery)
0041DoEvents
0042If Not rsTableControl2.EOF Then
0043 rsTableControl2.MoveLast
0044 ifields = rsTableControl2.Fields.Count - 1 'Ignore Code Location in field 0
0045 iFieldWidth = 1000 / ifields
0046 rsTableControl2.MoveFirst
0047End If
0048DoEvents
0049Set fsoTextFile2 = New FileSystemObject
0050FileName = FileName_Root & strFile_Sub & ".htm"
0051strOutputFile = strOutputFolder & FileName
0052Set tsTextFile = fsoTextFile2.CreateTextFile(strOutputFile, True, True)
0053'Headings
0054strLine = "<!DOCTYPE html><HTML lang=""en"">"
0055strLine = strLine & "<HEAD><meta charset=""utf-8""><TITLE>" & strTitle & "</TITLE><link href=""../TheosStyle.css"" rel=""stylesheet"" type=""text/css""><link rel=""shortcut icon"" href=""../TT_ICO.png"" /></HEAD><BODY><H1 align=""center""><B>" & strTitle & "</B></H1><CENTER>"
0056tsTextFile.WriteLine strLine
0057If IsMissing(Recent) Then
0058 strLine = "<h3>Full List</h3>"
0059Else
0060 strLine = "<h3>Recent List</h3>"
0061End If
0062strLine = strLine & "<p>This table lists all the recorded " & strRecent & "changes to my website generator, most recent first. The ""number"" is the length of the procedure in characters. A change is ""logged"" when the documenter is run. Currently the hyperlink is to the latest version of the code only." & strRecent_Meaning & "</p>"
0063tsTextFile.WriteLine strLine
0064If Not rsTableControl2.EOF Then
0065 strLine = "<TABLE class = ""Bridge"" WIDTH=1200>"
0066 tsTextFile.WriteLine strLine
0067 rsTableControl2.MoveFirst
0068 'Headings
0069 strLine = "<TR>"
0070 j = 1
0071 Do While j < ifields + 1
0072 If j = 1 Then
0073 Field_Width = 200
0074 Else
0075 Field_Width = iFieldWidth
0076 End If
0077 x = rsTableControl2.Fields(j).Name
0078 strLine = strLine & "<th width = " & Field_Width & ">" & x & "</th>"
0079 j = j + 1
0080 Loop
0081 strLine = strLine & "</TR>"
0082 tsTextFile.WriteLine strLine
0083 strHeader = strLine
0084 Do While Not rsTableControl2.EOF
0085 strLine = "<TR>"
0086 j = 1
0087 Do While j < ifields + 1
0088 If j = 1 Then
0089 Field_Width = 200
0090 Else
0091 Field_Width = iFieldWidth
0092 End If
0093 x = rsTableControl2.Fields(j) & ""
0094 If x = "" Then
0095 x = "&nbsp;"
0096 End If
0097 If j = 1 Then
0098 x = "<a href=""Documentation_Code_" & rsTableControl2.Fields(0) & ".htm#" & rsTableControl2.Fields(1) & """>" & x & "</a>"
0099 End If
0100 strLine = strLine & "<td width = " & Field_Width & ">" & x & "</td>"
0101 j = j + 1
0102 Loop
0103 strLine = strLine & "</TR>"
0104 tsTextFile.WriteLine strLine
0105 rsTableControl2.MoveNext
0106 Loop
0107 tsTextFile.WriteLine strHeader
0108 strLine = "</TABLE>"
0109 tsTextFile.WriteLine strLine
0110End If
0111'Page Footer
0112strLine = "<p>&nbsp;</p><TABLE Class = ""Bridge"" WIDTH=1000>"
0113tsTextFile.WriteLine strLine
0114strLine = "<TR>"
0115tsTextFile.WriteLine strLine
0116strLine = "<TH WIDTH=""30%"">&copy; Theo Todman; Apr. 2007 - " & MonthName(Month(Now())) & " " & Year(Now()) & "</TH>"
0117tsTextFile.WriteLine strLine
0118strLine = "<TH WIDTH=""40%"">Please address any comments on this page to <A HREF=""mailto:theo@theotodman.com"">theo@theotodman.com</A>.</TH>"
0119tsTextFile.WriteLine strLine
0120strLine = "<TH WIDTH=""30%""><A HREF=""../Notes/Notes_10/Notes_1010.htm"" TARGET = ""_top"">Website Maintenance Dashboard</A></TH>"
0121tsTextFile.WriteLine strLine
0122strLine = "</TR>"
0123tsTextFile.WriteLine strLine
0124strLine = "<TR>"
0125tsTextFile.WriteLine strLine
0126strLine = "<TH WIDTH=""30%""><A HREF=""../index.htm"" TARGET = ""_top"">Return to Theo Todman's Home Page</A></TH>"
0127tsTextFile.WriteLine strLine
0128strLine = "<TH WIDTH=""40%""><A HREF=""../Notes/Notes_11/Notes_1140.htm"" TARGET = ""_top"">Return to Theo Todman's Philosophy Page</A></TH>"
0129tsTextFile.WriteLine strLine
0130strLine = "<TH WIDTH=""30%"">Timestamp : <time datetime=""" & Year(Now()) & "-" & Right(Month(Now()) + 100, 2) & "-" & Right(Day(Now()) + 100, 2) & """ pubdate>" & Now() & "</time></TH>"
0131tsTextFile.WriteLine strLine
0132strLine = "</TR></TABLE></CENTER>"
0133tsTextFile.WriteLine strLine
0134 OK = CopyToTransfer(strOutputFolder, FileName)
0135Set tsTextFile = Nothing
0136End Sub

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


Source Code of: cmdAuto_Reference_Notes_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 24
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Private Sub cmdAuto_Reference_Notes_Click()
0002Dim MsgBox_Response
0003Dim Start_Time As Date
0004If MsgBox("Do you want to update the Note_Alternates and / or Excluded_Cognates Tables?", vbYesNo) = vbYes Then
0005 DoCmd.Close acTable, "Note_Alternates"
0006 DoCmd.OpenTable ("Note_Alternates")
0007 DoCmd.Close acTable, "Excluded_Cognates"
0008 DoCmd.OpenTable ("Excluded_Cognates")
0009Else
0010 MsgBox_Response = MsgBox("Do you want to regenerate all the Notes_Link pages?", vbYesNoCancel + vbDefaultButton2)
0011 If MsgBox_Response = vbYes Then
0012 Debug.Print Now() & " - Entering Auto_Reference_Notes_Regen"
0013 Start_Time = Now()
0014 Auto_Reference_Notes_Regen ("Yes")
0015 Debug.Print Now() & " - Returned from Auto_Reference_Notes_Regen in " & Round((Now() - Start_Time) * 24 * 60, 1) & " minutes."
0016 MsgBox ("Auto_Reference_Notes_Regen completed successfully in " & Round((Now() - Start_Time) * 24 * 60, 1) & " minutes.")
0017 Else
0018 If MsgBox_Response = vbNo Then
0019 automatic_processing = "No"
0020 Auto_Reference_Notes
0021 End If
0022 End If
0023End If
0024End Sub

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


Source Code of: cmdWebLinks_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 67
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Private Sub cmdWebLinks_Click()
0002Dim Start_Time As Date
0003Dim Webrefs_Option As String
0004Dim Option_Help As String
0005Dim rs As Recordset
0006Dim rsTableToRead As Recordset
0007Dim iManual_Check_Months As Integer
0008Dim Duration As Single
0009iManual_Check_Months = 3 'Parameter
0010 DoCmd.OpenQuery ("WebRef_Kernels_Updt")
0011 Set rs = CurrentDb.OpenRecordset("SELECT Max(Webrefs_Table.Date_Last_Checked) AS MaxOfDate_Last_Checked FROM Webrefs_Table WHERE (((Webrefs_Table.Issue)=""Manual Check OK""));")
0012If Not rs.EOF Then
0013 rs.MoveFirst
0014 If Now() - Nz(rs.Fields(0)) > iManual_Check_Months * 365 / 12 Then
0015 If MsgBox("It's time to check the manually-checked WebRefs! Do so now?", vbYesNo) = vbYes Then
0016 DoCmd.OpenQuery ("qryWebRefs_Check_Manual")
0017 MsgBox ("Blank the last-checked info in the query, run the recent-checker, and manually-check any that fail. ")
0018 End
0019 End If
0020 End If
0021End If
0022 Option_Help = "1. Update the Webrefs_Table Table"
0023 Option_Help = Option_Help & Chr$(10) & "2. Check The Webrefs_Table External Links"
0024Option_Help = Option_Help & Chr$(10) & "3. Regenerate the External Links Test Pages"
0025Option_Help = Option_Help & Chr$(10) & "4. Display Webrefs Errors"
0026Option_Help = Option_Help & Chr$(10) & "5. Translate WebRefs"
0027 Option_Help = Option_Help & Chr$(10) & "6. Re-create the WebRef_Maps Table"
0028Webrefs_Option = InputBox(Option_Help, "Enter an integer Webrefs Option", 1)
0029If Len(Webrefs_Option) = 0 Then
0030 End
0031End If
0032If Webrefs_Option < "1" Or Webrefs_Option > "6" Then
0033 MsgBox ("Choose an Option between 1 and 6")
0034 End
0035End If
0036Start_Time = Now()
0037Select Case Webrefs_Option
0038 Case 1
0039 DoCmd.OpenQuery ("qrySearch_Webrefs_Table")
0040 Case 2
0041 Webrefs_Update
0042 MsgBox ("External Links Spider run successfully in " & Round((Now() - Start_Time) * 24 * 60, 1) & " minutes.")
0043 Case 3
0044 WebRefs_Checker_Pages_Gen
0045 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM BookPaperControl WHERE ID = ""WebRefs_Checker_Pages_Gen"";")
0046 WebRefs_Checker_Pages_Gen
0047 Duration = Round((Now() - Start_Time) * 24 * 60, 1)
0048 rsTableToRead.Edit
0049 rsTableToRead.Fields(1) = Now()
0050 rsTableToRead.Fields(2) = Duration
0051 rsTableToRead.Update
0052 Set rsTableToRead = Nothing
0053 MsgBox ("External Links Test Pages output successfully in " & Round((Now() - Start_Time) * 24 * 60, 1) & " minutes.")
0054 Case 4
0055 DoCmd.Close acTable, "WebRef_Missing_IDs"
0056 DoCmd.OpenTable ("WebRef_Missing_IDs")
0057 DoCmd.OpenQuery ("WebRefs_Duplicates")
0058 DoCmd.OpenQuery ("WebRefs_Error_List")
0059 DoCmd.OpenQuery ("WebRefs_Error_Summary")
0060 Case 5
0061 Translate_Webrefs
0062 Case 6
0063 Map_WebRefs
0064 Case Else
0065 End
0066End Select
0067End Sub

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


Source Code of: cmdWebsiteMaintenanceDashboard_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 35
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Private Sub cmdWebsiteMaintenanceDashboard_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 = ""WebsiteMaintenanceDashboard"";")
0010RunDate = rsTableToRead.Fields(1)
0011strRunTime = Round(rsTableToRead.Fields(2), 1)
0012strMessage = "Do you want to regenerate the ""Website: Maintenance Dashboard"" page?"""
0013strMessage = strMessage & Chr$(10) & "The last run on " & RunDate & " took " & strRunTime & " minutes."
0014RootCreated = ""
0015If MsgBox(strMessage, vbYesNo) = vbYes Then
0016 StartTime = Now()
0017 DoCmd.OpenQuery ("Temp_Note_Timestamp_Update") 'Added October 2024 ... to give better indication of the latest changed date for Temp Notes (to protect against 'Full Regen' date for temp notes)
0018 Monthly_Report_Note1010_Update
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
0027If Duration < 1 Then
0028 Duration = Round((Now() - StartTime) * 24 * 60 * 60)
0029 MsgBox "Maintenance Dashboard Creation Complete in " & Duration & " seconds.", vbOKOnly, "Create Maintenance Dashboard Web Page"
0030Else
0031 MsgBox "Maintenance Dashboard Creation Complete in " & Duration & " minutes.", vbOKOnly, "Create Maintenance Dashboard Web Page"
0032End If
0033Set rsTableToRead = Nothing
0034Set rsTableToRead2 = Nothing
0035End Sub

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


Source Code of: Functor_01
Procedure Type: Public Function
Module: Functors
Lines of Code: 28
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor_01(Note_ID, Note_Title, Note_Text, YTD)
0002'Quarterly report: activity insert
0003Dim rs As Recordset
0004Dim strQuery As String
0005Dim strReport_Date As String
0006Dim strYear As String
0007Dim strQuarter As String
0008'Find the Report Year & Quarter
0009 OK = Find_Report_Period(Note_Title, strYear, strQuarter)
0010If YTD = "Yes" Then
0011 strReport_Date = strYear
0012 If strQuarter <> "Q4" Then
0013 strReport_Date = strReport_Date - 1
0014 End If
0015Else
0016 strReport_Date = strYear & "_" & strQuarter
0017End If
0018 strQuery = "SELECT Status_Tasklists.Report_Text FROM Status_Tasklists WHERE Status_Tasklists.Note_ID = " & Note_ID & " AND Status_Tasklists.Note_Period = """ & strReport_Date & """;"
0019Set rs = CurrentDb.OpenRecordset(strQuery)
0020If Not rs.EOF Then
0021 rs.MoveFirst
0022 Note_Text = rs.Fields(0)
0023 Functor_01 = "Yes"
0024Else
0025 Functor_01 = "No"
0026End If
0027Set rs = Nothing
0028End Function

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


Source Code of: StartTimer
Procedure Type: Public Sub
Module: StopWatch
Lines of Code: 3

Line-No. / Ref.Code Line
0001Public Sub StartTimer()
0002 mlngStart = GetTickCount
0003End Sub

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


Source Code of: Translate_Webrefs
Procedure Type: Public Sub
Module: Testing
Lines of Code: 172
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Translate_Webrefs()
0002Dim rsWebRef_Translations As Recordset
0003Dim rsObject As Recordset
0004Dim strQuery As String
0005Dim Old_WebRef As String
0006Dim New_WebRef As String
0007Dim Object As String
0008Dim iUpdates As Long
0009Dim Duration As Single
0010Dim RunStartTime As Date
0011Dim Message As String
0012Message = MsgBox("Translate WebRefs? Update the WebRefs_Translation Table?", vbYesNoCancel)
0013If Message = vbCancel Then
0014 End
0015Else
0016 DoCmd.OpenQuery ("WebRefs_Translation_Add")
0017 If Message = vbYes Then
0018 DoCmd.OpenTable ("WebRefs_Translation")
0019 DoCmd.OpenQuery ("qrySearch_Webrefs_Table")
0020 End
0021 End If
0022End If
0023iUpdates = 0
0024RunStartTime = Now()
0025 strQuery = "SELECT * FROM WebRefs_Translation WHERE [Done?] = False;"
0026Set rsWebRef_Translations = CurrentDb.OpenRecordset(strQuery)
0027If rsWebRef_Translations.EOF Then
0028 MsgBox ("No translations to do!")
0029 End
0030Else
0031 rsWebRef_Translations.MoveFirst
0032End If
0033Do Until rsWebRef_Translations.EOF
0034 Old_WebRef = "+W" & rsWebRef_Translations.Fields(0) & "W+"
0035 New_WebRef = "+W" & rsWebRef_Translations.Fields(1) & "W+"
0036 'Translate Notes
0037 strQuery = "SELECT Notes.ID, Notes.Item_Text FROM Notes WHERE (((Notes.Item_Text) Like ""*" & Old_WebRef & "*""));"
0038 Set rsObject = CurrentDb.OpenRecordset(strQuery)
0039 If Not rsObject.EOF Then
0040 rsObject.MoveFirst
0041 Do Until rsObject.EOF
0042 Object = rsObject.Fields(1)
0043 Object = Replace(Object, Old_WebRef, New_WebRef)
0044 rsObject.Edit
0045 rsObject.Fields(1) = Object
0046 rsObject.Update
0047 iUpdates = iUpdates + 1
0048 Debug.Print Now() & " - "; "Note:" & rsObject.Fields(0); " Old_WebRef: "; Old_WebRef
0049 rsObject.MoveNext
0050 Loop
0051 End If
0052 Set rsObject = Nothing
0053 'Translate Notes_Archive
0054 strQuery = "SELECT Notes_Archive.ID, Notes_Archive.Item_Text FROM Notes_Archive WHERE (((Notes_Archive.Item_Text) Like ""*" & Old_WebRef & "*""));"
0055 Set rsObject = CurrentDb.OpenRecordset(strQuery)
0056 If Not rsObject.EOF Then
0057 rsObject.MoveFirst
0058 Do Until rsObject.EOF
0059 Object = rsObject.Fields(1)
0060 Object = Replace(Object, Old_WebRef, New_WebRef)
0061 rsObject.Edit
0062 rsObject.Fields(1) = Object
0063 rsObject.Update
0064 iUpdates = iUpdates + 1
0065 Debug.Print Now() & " - "; "Note_Archive:" & rsObject.Fields(0); " Old_WebRef: "; Old_WebRef
0066 rsObject.MoveNext
0067 Loop
0068 End If
0069 Set rsObject = Nothing
0070 'Translate Book Abstracts
0071 strQuery = "SELECT Books.ID1, Books.Abstract FROM Books WHERE (((Books.Abstract) Like ""*" & Old_WebRef & "*""));"
0072 Set rsObject = CurrentDb.OpenRecordset(strQuery)
0073 If Not rsObject.EOF Then
0074 rsObject.MoveFirst
0075 Do Until rsObject.EOF
0076 Object = rsObject.Fields(1)
0077 Object = Replace(Object, Old_WebRef, New_WebRef)
0078 rsObject.Edit
0079 rsObject.Fields(1) = Object
0080 rsObject.Update
0081 iUpdates = iUpdates + 1
0082 Debug.Print Now() & " - "; "Book Abstract:" & rsObject.Fields(0); " Old_WebRef: "; Old_WebRef
0083 rsObject.MoveNext
0084 Loop
0085 End If
0086 Set rsObject = Nothing
0087 'Translate Book Comments
0088 strQuery = "SELECT Books.ID1, Books.Comments FROM Books WHERE (((Books.Comments) Like ""*" & Old_WebRef & "*""));"
0089 Set rsObject = CurrentDb.OpenRecordset(strQuery)
0090 If Not rsObject.EOF Then
0091 rsObject.MoveFirst
0092 Do Until rsObject.EOF
0093 Object = rsObject.Fields(1)
0094 Object = Replace(Object, Old_WebRef, New_WebRef)
0095 rsObject.Edit
0096 rsObject.Fields(1) = Object
0097 rsObject.Update
0098 iUpdates = iUpdates + 1
0099 Debug.Print Now() & " - "; "Book Comment:" & rsObject.Fields(0); " Old_WebRef: "; Old_WebRef
0100 rsObject.MoveNext
0101 Loop
0102 End If
0103 Set rsObject = Nothing
0104 'Translate Paper Abstracts
0105 strQuery = "SELECT Papers.ID, Papers.Abstract FROM Papers WHERE (((Papers.Abstract) Like ""*" & Old_WebRef & "*""));"
0106 Set rsObject = CurrentDb.OpenRecordset(strQuery)
0107 If Not rsObject.EOF Then
0108 rsObject.MoveFirst
0109 Do Until rsObject.EOF
0110 Object = rsObject.Fields(1)
0111 Object = Replace(Object, Old_WebRef, New_WebRef)
0112 rsObject.Edit
0113 rsObject.Fields(1) = Object
0114 rsObject.Update
0115 iUpdates = iUpdates + 1
0116 Debug.Print Now() & " - "; "Paper Abstract:" & rsObject.Fields(0); " Old_WebRef: "; Old_WebRef
0117 rsObject.MoveNext
0118 Loop
0119 End If
0120 Set rsObject = Nothing
0121 'Translate Paper Comments
0122 strQuery = "SELECT Papers.ID, Papers.Comments FROM Papers WHERE (((Papers.Comments) Like ""*" & Old_WebRef & "*""));"
0123 Set rsObject = CurrentDb.OpenRecordset(strQuery)
0124 If Not rsObject.EOF Then
0125 rsObject.MoveFirst
0126 Do Until rsObject.EOF
0127 Object = rsObject.Fields(1)
0128 Object = Replace(Object, Old_WebRef, New_WebRef)
0129 rsObject.Edit
0130 rsObject.Fields(1) = Object
0131 rsObject.Update
0132 iUpdates = iUpdates + 1
0133 Debug.Print Now() & " - "; "Paper Comment:" & rsObject.Fields(0); " Old_WebRef: "; Old_WebRef
0134 rsObject.MoveNext
0135 Loop
0136 End If
0137 Set rsObject = Nothing
0138 'Translate Authors
0139 strQuery = "SELECT Authors.Author_ID, Authors.Author_Narrative FROM Authors WHERE (((Authors.Author_Narrative) Like ""*" & Old_WebRef & "*""));"
0140 Set rsObject = CurrentDb.OpenRecordset(strQuery)
0141 If Not rsObject.EOF Then
0142 rsObject.MoveFirst
0143 Do Until rsObject.EOF
0144 Object = rsObject.Fields(1)
0145 Object = Replace(Object, Old_WebRef, New_WebRef)
0146 rsObject.Edit
0147 rsObject.Fields(1) = Object
0148 rsObject.Update
0149 iUpdates = iUpdates + 1
0150 Debug.Print Now() & " - "; "Author Abstract:" & rsObject.Fields(0); " Old_WebRef: "; Old_WebRef
0151 rsObject.MoveNext
0152 Loop
0153 End If
0154 Set rsObject = Nothing
0155 rsWebRef_Translations.Edit
0156 rsWebRef_Translations.Fields(2) = True
0157 rsWebRef_Translations.Update
0158 rsWebRef_Translations.MoveNext
0159Loop
0160Set rsWebRef_Translations = Nothing
0161'Flag translated Webrefs as Defunct
0162 strQuery = "UPDATE WebRefs_Translation INNER JOIN Webrefs_Table ON WebRefs_Translation.WebRef_Old = Webrefs_Table.ID SET Webrefs_Table.[Defunct?] = True;"
0163DoCmd.RunSQL (strQuery)
0164 DoCmd.OpenQuery ("WebRefs_Translation_Check")
0165Duration = Round((Now() - RunStartTime) * 24 * 60, 1)
0166If Duration < 1 Then
0167 Duration = Round((Now() - RunStartTime) * 24 * 60 * 60)
0168 MsgBox "WebRefs Translated in " & Duration & " seconds. " & iUpdates & " records updated.", vbOKOnly, "Translate WebRefs"
0169Else
0170 MsgBox "WebRefs Translated in " & Duration & " minutes. " & iUpdates & " records updated.", vbOKOnly, "Translate WebRefs"
0171End If
0172End Sub

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


Source Code of: WebpageGenBooksRecent
Procedure Type: Public Sub
Module: Webpage_Generators
Lines of Code: 27
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub WebpageGenBooksRecent()
0002Dim StartTime As Double
0003Dim rsTableToRead As Recordset
0004Dim Duration As Double
0005Dim strRunTime As String
0006Dim RunDate As Date
0007 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM BookPaperControl WHERE ID = ""WebpageGenBooksRecent"";")
0008RunDate = rsTableToRead.Fields(1)
0009strRunTime = Round(rsTableToRead.Fields(2), 1)
0010StartTime = Now()
0011strControlTable = "Books_Table_Recent"
0012strOutputFileShort = "BookCatalogRecent"
0013strOutputFolder = TheoWebsiteRoot & "\"
0014strOutputFile = strOutputFolder & strOutputFileShort
0015 strDataQuery = "Books - Recent"
0016strSplitTable = "No"
0017strControlBreakType = "Initial"
0018strControlBreakType2 = ""
0019Main_Header = "No"
0020 CreatePapersWebTable
0021Duration = Round((Now() - StartTime) * 24 * 60, 1)
0022rsTableToRead.Edit
0023rsTableToRead.Fields(1) = Now()
0024rsTableToRead.Fields(2) = Duration
0025rsTableToRead.Update
0026Set rsTableToRead = Nothing
0027End Sub

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


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

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

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


© Theo Todman, June 2007 - May 2025. 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