Line-No. / Ref. Code Line
0001 Public Sub Archive_Xtab_Page(Optional Recent)
0002 'Create web-page of (recent) Code changes
0003 Dim strOutputFolder As String
0004 Dim strOutputFile As String
0005 Dim strLine As String
0006 Dim strHeader As String
0007 Dim rsTableControl2 As Recordset
0008 Dim j As Integer
0009 Dim FileName As String
0010 Dim FileName_Root As String
0011 Dim ifields As Integer
0012 Dim iFieldWidth As Integer
0013 Dim Field_Width As Integer
0014 Dim x As String
0015 Dim strRecent As String
0016 Dim strRecent_Meaning As String
0017 Dim strQuery As String
0018 Dim strFile_Sub As String
0019 Dim strTitle As String
0020 strOutputFolder = TheoWebsiteRoot & "\Documentation\"
0021 If SubSystem & "" = "" Then
0022 FileName_Root = "Code_Archive"
0023 Else
0024 FileName_Root = SubSystem & "_Code_Archive"
0025 End If
0026 If IsMissing(Recent) Then
0027 strFile_Sub = ""
0028 strTitle = ""
0029 strRecent = ""
0030 strRecent_Meaning = ""
0031 strQuery = "Code_Archive_Xtab"
0032 Else
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"
0038 End If
0039 strTitle = "Theo Todman's " & strTitle & Trim(SubSystem & " Code Changes")
0040 Set rsTableControl2 = CurrentDb.OpenRecordset(strQuery)
0041 DoEvents
0042 If 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
0047 End If
0048 DoEvents
0049 Set fsoTextFile2 = New FileSystemObject
0050 FileName = FileName_Root & strFile_Sub & ".htm"
0051 strOutputFile = strOutputFolder & FileName
0052 Set tsTextFile = fsoTextFile2.CreateTextFile(strOutputFile, True, True)
0053 'Headings
0054 strLine = ""
0055 strLine = strLine & "" & strTitle & " " & strTitle & " "
0056 tsTextFile.WriteLine strLine
0057 If IsMissing(Recent) Then
0058 strLine = "Full List "
0059 Else
0060 strLine = "Recent List "
0061 End If
0062 strLine = strLine & "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 & "
"
0063 tsTextFile.WriteLine strLine
0064 If Not rsTableControl2.EOF Then
0065 strLine = " "
0066 tsTextFile.WriteLine strLine
0067 rsTableControl2.MoveFirst
0068 'Headings
0069 strLine = ""
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 & "" & x & " "
0079 j = j + 1
0080 Loop
0081 strLine = strLine & " "
0082 tsTextFile.WriteLine strLine
0083 strHeader = strLine
0084 Do While Not rsTableControl2.EOF
0085 strLine = ""
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 = " "
0096 End If
0097 If j = 1 Then
0098 x = "" & x & " "
0099 End If
0100 strLine = strLine & "" & x & " "
0101 j = j + 1
0102 Loop
0103 strLine = strLine & " "
0104 tsTextFile.WriteLine strLine
0105 rsTableControl2.MoveNext
0106 Loop
0107 tsTextFile.WriteLine strHeader
0108 strLine = "
"
0109 tsTextFile.WriteLine strLine
0110 End If
0111 'Page Footer
0112 strLine = "
"
0113 tsTextFile.WriteLine strLine
0114 strLine = ""
0115 tsTextFile.WriteLine strLine
0116 strLine = "© Theo Todman; Apr. 2007 - " & MonthName(Month(Now())) & " " & Year(Now()) & " "
0117 tsTextFile.WriteLine strLine
0118 strLine = "Please address any comments on this page to theo@theotodman.com . "
0119 tsTextFile.WriteLine strLine
0120 strLine = "Website Maintenance Dashboard "
0121 tsTextFile.WriteLine strLine
0122 strLine = " "
0123 tsTextFile.WriteLine strLine
0124 strLine = ""
0125 tsTextFile.WriteLine strLine
0126 strLine = "Return to Theo Todman's Home Page "
0127 tsTextFile.WriteLine strLine
0128 strLine = "Return to Theo Todman's Philosophy Page "
0129 tsTextFile.WriteLine strLine
0130 strLine = "Timestamp : " & Now() & " "
0131 tsTextFile.WriteLine strLine
0132 strLine = "
"
0133 tsTextFile.WriteLine strLine
0134 OK = CopyToTransfer(strOutputFolder, FileName)
0135 Set tsTextFile = Nothing
0136 End Sub
Line-No. / Ref. Code Line
0001 Private Sub cmdWebLinks_Click()
0002 Dim Start_Time As Date
0003 Dim Webrefs_Option As String
0004 Dim Option_Help As String
0005 Dim rs As Recordset
0006 Dim rsTableToRead As Recordset
0007 Dim iManual_Check_Months As Integer
0008 Dim Duration As Single
0009 iManual_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""));")
0012 If 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
0021 End If
0022 Option_Help = "1. Update the Webrefs_Table Table"
0023 Option_Help = Option_Help & Chr$(10) & "2. Check The Webrefs_Table External Links"
0024 Option_Help = Option_Help & Chr$(10) & "3. Regenerate the External Links Test Pages"
0025 Option_Help = Option_Help & Chr$(10) & "4. Display Webrefs Errors"
0026 Option_Help = Option_Help & Chr$(10) & "5. Translate WebRefs"
0027 Option_Help = Option_Help & Chr$(10) & "6. Re-create the WebRef_Maps Table"
0028 Webrefs_Option = InputBox(Option_Help, "Enter an integer Webrefs Option", 1)
0029 If Len(Webrefs_Option) = 0 Then
0030 End
0031 End If
0032 If Webrefs_Option < "1" Or Webrefs_Option > "6" Then
0033 MsgBox ("Choose an Option between 1 and 6")
0034 End
0035 End If
0036 Start_Time = Now()
0037 Select 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
0066 End Select
0067 End Sub
Line-No. / Ref. Code Line
0001 Private Sub cmdWebsiteMaintenanceDashboard_Click()
0002 Dim strMessage As String
0003 Dim StartTime As Double
0004 Dim rsTableToRead As Recordset
0005 Dim rsTableToRead2 As Recordset
0006 Dim Duration As Double
0007 Dim strRunTime As String
0008 Dim RunDate As Date
0009 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM BookPaperControl WHERE ID = ""WebsiteMaintenanceDashboard"";")
0010 RunDate = rsTableToRead.Fields(1)
0011 strRunTime = Round(rsTableToRead.Fields(2), 1)
0012 strMessage = "Do you want to regenerate the ""Website: Maintenance Dashboard"" page?"""
0013 strMessage = strMessage & Chr$(10) & "The last run on " & RunDate & " took " & strRunTime & " minutes."
0014 RootCreated = ""
0015 If MsgBox(strMessage, vbYesNo) = vbYes Then
0016 StartTime = Now()
0017 Monthly_Report_Note1010_Update
0018 Duration = Round((Now() - StartTime) * 24 * 60, 1)
0019 rsTableToRead.Edit
0020 rsTableToRead.Fields(1) = Now()
0021 rsTableToRead.Fields(2) = Duration
0022 rsTableToRead.Update
0023 Else
0024 Exit Sub
0025 End If
0026 If Duration < 1 Then
0027 Duration = Round((Now() - StartTime) * 24 * 60 * 60)
0028 MsgBox "Maintenance Dashboard Creation Complete in " & Duration & " seconds.", vbOKOnly, "Create Maintenance Dashboard Web Page"
0029 Else
0030 MsgBox "Maintenance Dashboard Creation Complete in " & Duration & " minutes.", vbOKOnly, "Create Maintenance Dashboard Web Page"
0031 End If
0032 Set rsTableToRead = Nothing
0033 Set rsTableToRead2 = Nothing
0034 End Sub
Line-No. / Ref. Code Line
0001 Public Sub Translate_Webrefs()
0002 Dim rsWebRef_Translations As Recordset
0003 Dim rsObject As Recordset
0004 Dim strQuery As String
0005 Dim Old_WebRef As String
0006 Dim New_WebRef As String
0007 Dim Object As String
0008 Dim iUpdates As Long
0009 Dim Duration As Single
0010 Dim RunStartTime As Date
0011 Dim Message As String
0012 Message = MsgBox("Translate WebRefs? Update the WebRefs_Translation Table?", vbYesNoCancel)
0013 If Message = vbCancel Then
0014 End
0015 Else
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
0022 End If
0023 iUpdates = 0
0024 RunStartTime = Now()
0025 strQuery = "SELECT * FROM WebRefs_Translation WHERE [Done?] = False;"
0026 Set rsWebRef_Translations = CurrentDb.OpenRecordset(strQuery)
0027 If rsWebRef_Translations.EOF Then
0028 MsgBox ("No translations to do!")
0029 End
0030 Else
0031 rsWebRef_Translations.MoveFirst
0032 End If
0033 Do 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
0159 Loop
0160 Set 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;"
0163 DoCmd.RunSQL (strQuery)
0164 DoCmd.OpenQuery ("WebRefs_Translation_Check")
0165 Duration = Round((Now() - RunStartTime) * 24 * 60, 1)
0166 If Duration < 1 Then
0167 Duration = Round((Now() - RunStartTime) * 24 * 60 * 60)
0168 MsgBox "WebRefs Translated in " & Duration & " seconds. " & iUpdates & " records updated.", vbOKOnly, "Translate WebRefs"
0169 Else
0170 MsgBox "WebRefs Translated in " & Duration & " minutes. " & iUpdates & " records updated.", vbOKOnly, "Translate WebRefs"
0171 End If
0172 End Sub