Line-No. / Ref. Code Line
0001 Private Sub cmdTimelines_Click()
0002 Dim x As String
0003 Dim strMessage As String
0004 Dim strQuery As String
0005 Dim i As Integer
0006 Dim strPhotoQuery As String
0007 Dim strPhotoType As String
0008 Dim Directory_From As String
0009 strMessage = "Update and / or output a Timeline page? Choose from the numeric options below:-" & Chr(10)
0010 strMessage = strMessage & Chr(10) & "01. Blog"
0011 strMessage = strMessage & Chr(10) & "02. Coxes Farm Timeline"
0012 strMessage = strMessage & Chr(10) & "03. Coxes Farm (Repairs) Photo List"
0013 strMessage = strMessage & Chr(10) & "04. Coxes Farm (Pre-Repairs) Photo List"
0014 strMessage = strMessage & Chr(10) & "05. Coxes Farm Gardens Photo List"
0015 strMessage = strMessage & Chr(10) & "06. Search Photos_Raw Link_Key(s) or File Names"
0016 strMessage = strMessage & Chr(10) & "07. Update Photos_Raw Exclusions"
0017 strMessage = strMessage & Chr(10) & "08. Correct inconsistent Photo_Types"
0018 x = InputBox(strMessage, "Choose a Timeline Option", 8)
0019 If x = "" Then
0020 MsgBox ("Request omitted; try again")
0021 Exit Sub
0022 End If
0023 If Not IsNumeric(x) Then
0024 MsgBox ("Request not numeric; try again")
0025 Exit Sub
0026 Else
0027 i = x
0028 End If
0029 If i > 8 Or i < 1 Then
0030 MsgBox ("Request out of range; try again")
0031 Exit Sub
0032 End If
0033 If i = 1 Then
0034 strMessage = "Update the Blog Table?"
0035 If MsgBox(strMessage, vbYesNo) = vbYes Then
0036 DoCmd.OpenTable ("Blog")
0037 Exit Sub
0038 End If
0039 strMessage = "Output the Blog?"
0040 If MsgBox(strMessage, vbYesNo) = vbYes Then
0041 DoCmd.RunSQL ("DELETE * FROM Notes_To_Regen;")
0042 DoCmd.RunSQL ("INSERT INTO Notes_To_Regen ( Note_ID ) SELECT Notes.ID FROM Notes WHERE (((Notes.ID)=268));") 'Regenerate the Blog Note
0043 Archive_Notes_Now = "No"
0044 Regenerate_the_Links = "No"
0045 Regen_Notes_Only = "Yes"
0046 CreateNotesWebPages ("Yes")
0047 MsgBox (Now() & " - Blog Output OK")
0048 Exit Sub
0049 End If
0050 End If
0051 If i = 2 Then
0052 strMessage = "Update the Timeline for CoxesFarm?"
0053 If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0054 strQuery = "Timeline_CoxesFarm"
0055 DoCmd.OpenQuery (strQuery)
0056 Exit Sub
0057 End If
0058 strMessage = "Output the Coxes Farm Timeline Page?"
0059 If MsgBox(strMessage, vbYesNo) = vbYes Then
0060 DoCmd.RunSQL ("DELETE * FROM Notes_To_Regen;")
0061 DoCmd.RunSQL ("INSERT INTO Notes_To_Regen ( Note_ID ) SELECT Notes.ID FROM Notes WHERE (((Notes.ID)=1276));") 'Regenerate the Coxes Farm Timeline Note
0062 Archive_Notes_Now = "No"
0063 Regenerate_the_Links = "No"
0064 Regen_Notes_Only = "Yes"
0065 CreateNotesWebPages ("Yes")
0066 MsgBox (Now() & " - Coxes Farm Timeline Output OK")
0067 Exit Sub
0068 End If
0069 End If
0070 If i = 3 Then
0071 strPhotoQuery = "Coxes_Farm_Repairs"
0072 strPhotoType = "CoxesFarmRepairs"
0073 Directory_From = "C:\Theo's Files\Coxes Farm Repairs\Photos_Import_Repairs\"
0074 strMessage = "Import more Photos for Coxes_Farm_Repairs?"
0075 End If
0076 If i = 4 Then
0077 strPhotoQuery = "Coxes_Farm_Pre_Repairs"
0078 strPhotoType = "CoxesFarmPreRepairs"
0079 Directory_From = "C:\Theo's Files\Coxes Farm Repairs\Photos_Import_PreRepairs\"
0080 strMessage = "Import more Photos for Coxes_Farm_Pre_Repairs?"
0081 End If
0082 If i = 5 Then
0083 strPhotoQuery = "Coxes_Farm_Gardens"
0084 strPhotoType = "CoxesFarmGardens"
0085 Directory_From = "C:\Theo's Files\Coxes Farm Repairs\Photos_Import_Garden\"
0086 strMessage = "Import more Photos for Coxes_Farm_Gardens?"
0087 End If
0088 If i = 3 Or i = 4 Or i = 5 Then
0089 If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0090 Create_Timeline (i)
0091 Photo_Preparation (strPhotoType)
0092 OK = Photo_Copy(strPhotoQuery, Directory_From)
0093 End If
0094 strMessage = "Update the Photo_Narratives table with Monthly Narratives?"
0095 If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0096 strQuery = "Photo_Narratives"
0097 DoCmd.OpenTable (strQuery)
0098 Stop
0099 End If
0100 strMessage = "Update the Photos_Raw table (to add / amend the narratives of or include / exclude individual photos)?"
0101 If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0102 DoCmd.OpenQuery (strPhotoQuery)
0103 Stop
0104 Photo_Preparation (strPhotoType)
0105 End If
0106 End If
0107 If i = 3 Then
0108 strMessage = "Output the Coxes Farm (Repairs) Photo List Page? Note that Note 1278 has to be set to 'Temp' for the Functor to import the changed data. "
0109 If MsgBox(strMessage, vbYesNo) = vbYes Then
0110 DoCmd.RunSQL ("DELETE * FROM Notes_To_Regen;")
0111 DoCmd.RunSQL ("INSERT INTO Notes_To_Regen ( Note_ID ) SELECT Notes.ID FROM Notes WHERE (((Notes.ID)=1278));") 'Regenerate the Coxes Farm Timeline Note
0112 Archive_Notes_Now = "No"
0113 Regenerate_the_Links = "No"
0114 Regen_Notes_Only = "Yes"
0115 CreateNotesWebPages ("Yes")
0116 MsgBox (Now() & " - Coxes Farm Repairs Timeline Output OK")
0117 Exit Sub
0118 End If
0119 End If
0120 If i = 4 Then
0121 strMessage = "Output the Coxes Farm (Pre-Repairs) Photo List Page? Note that Note 1282 has to be set to 'Temp' for the Functor to import the changed data. "
0122 If MsgBox(strMessage, vbYesNo) = vbYes Then
0123 DoCmd.RunSQL ("DELETE * FROM Notes_To_Regen;")
0124 DoCmd.RunSQL ("INSERT INTO Notes_To_Regen ( Note_ID ) SELECT Notes.ID FROM Notes WHERE (((Notes.ID)=1282));") 'Regenerate the Coxes Farm Timeline Note
0125 Archive_Notes_Now = "No"
0126 Regenerate_the_Links = "No"
0127 Regen_Notes_Only = "Yes"
0128 CreateNotesWebPages ("Yes")
0129 MsgBox (Now() & " - Coxes Farm Pre-Repair Timeline Output OK")
0130 Exit Sub
0131 End If
0132 End If
0133 If i = 5 Then
0134 strMessage = "Output the Coxes Farm Gardens Photo List Page? Note that Note 1283 has to be set to 'Temp' for the Functor to import the changed data. "
0135 If MsgBox(strMessage, vbYesNo) = vbYes Then
0136 DoCmd.RunSQL ("DELETE * FROM Notes_To_Regen;")
0137 DoCmd.RunSQL ("INSERT INTO Notes_To_Regen ( Note_ID ) SELECT Notes.ID FROM Notes WHERE (((Notes.ID)=1283));") 'Regenerate the Coxes Farm Timeline Note
0138 Archive_Notes_Now = "No"
0139 Regenerate_the_Links = "No"
0140 Regen_Notes_Only = "Yes"
0141 CreateNotesWebPages ("Yes")
0142 MsgBox (Now() & " - Coxes Farm Gardens Timeline Output OK")
0143 Exit Sub
0144 End If
0145 End If
0146 If i = 6 Then
0147 DoCmd.OpenQuery ("Search_Photos_Raw")
0148 End If
0149 If i = 7 Then
0150 DoCmd.RunSQL ("DELETE Photo_Raw_Excluded_Link_Keys.* FROM Photo_Raw_Excluded_Link_Keys;")
0151 DoCmd.OpenQuery ("Photo_Raw_Excluded_Link_KeysQ")
0152 DoCmd.OpenQuery ("Photos_Raw_Excluded")
0153 End If
0154 If i = 8 Then
0155 DoCmd.RunSQL ("DELETE Photo_Raw_Excluded_Link_Keys.* FROM Photo_Raw_Excluded_Link_Keys;") 'Use a convenient table!
0156 DoCmd.OpenQuery ("Photo_Type_Goup_Mismatch_Gen")
0157 DoCmd.OpenQuery ("Photos_Raw_MultiType_List")
0158 End If
0159 End Sub
Line-No. / Ref. Code Line
0001 Public Sub Code_Archive()
0002 'Add missing Procedures
0003 DoCmd.RunSQL ("INSERT INTO Code_Archive_Table ( Procedure_Name, Archive_Date, Procedure_Type, [Module], Code, Lines, ID, Code_Location, [Parameters] ) SELECT Code_Table.Procedure_Name, Now() AS Expr1, Code_Table.Procedure_Type, Code_Table.Module, Code_Table.Code, Code_Table.Lines, Code_Table.ID, Code_Table.Code_Location, Code_Table.Parameters FROM Code_Table LEFT JOIN Code_Archive_Table ON Code_Table.Procedure_Name = Code_Archive_Table.Procedure_Name WHERE (((Code_Archive_Table.Procedure_Name) Is Null));")
0004 'Add changed procedures
0005 DoCmd.RunSQL ("INSERT INTO Code_Archive_Table ( Procedure_Name, Archive_Date, Procedure_Type, [Module], Lines, ID, Code_Location, [Parameters], Code ) SELECT Code_Table.Procedure_Name, Now() AS [Date], Code_Table.Procedure_Type, Code_Table.Module, Code_Table.Lines, Code_Table.ID, Code_Table.Code_Location, Code_Table.Parameters, Code_Table.Code FROM (Code_Table INNER JOIN Code_Archive_Table_Latest ON Code_Table.Procedure_Name = Code_Archive_Table_Latest.Procedure_Name) INNER JOIN Code_Archive_Table ON (Code_Archive_Table_Latest.MaxOfArchive_Date = Code_Archive_Table.Archive_Date) AND (Code_Archive_Table_Latest.Procedure_Name = Code_Archive_Table.Procedure_Name) WHERE (((Code_Table.Code)<>[Code_Archive_Table]![Code]));")
0006 'Delete archives that are duplicates
0007 Code_Archive_Prune
0008 'Maybe add a "Retired Code" page here?
0009 End Sub
Line-No. / Ref. Code Line
0001 Public Function Mark_Duplicate_Abstract_Footnotes(strType, Optional ID)
0002 Dim strQuery As String
0003 Dim rs As Recordset
0004 Dim iID As Integer
0005 Dim iID_Saved As Integer
0006 Dim strFN_Text_Saved As String
0007 Dim iFN_ID_Saved As Integer
0008 Dim iMaster_ID As Integer
0009 If IsMissing(ID) Then
0010 iID = 0
0011 Else
0012 iID = ID
0013 End If
0014 If iID = 0 Then
0015 strQuery = "SELECT Abstract_Footnotes.Object_Type, Abstract_Footnotes.Object_ID, Abstract_Footnotes.FN_Text, Abstract_Footnotes.FN_ID, Abstract_Footnotes.Master_ID FROM Abstract_Footnotes WHERE (((Abstract_Footnotes.Object_Type) = """ & strType & """)) ORDER BY Abstract_Footnotes.Object_Type, Abstract_Footnotes.Object_ID, Abstract_Footnotes.FN_Text, Abstract_Footnotes.FN_ID;"
0016 Else
0017 strQuery = "SELECT Abstract_Footnotes.Object_Type, Abstract_Footnotes.Object_ID, Abstract_Footnotes.FN_Text, Abstract_Footnotes.FN_ID, Abstract_Footnotes.Master_ID FROM Abstract_Footnotes WHERE (((Abstract_Footnotes.Object_Type) = """ & strType & """) AND ((Abstract_Footnotes.Object_ID) = " & iID & ")) ORDER BY Abstract_Footnotes.FN_Text, Abstract_Footnotes.FN_ID;"
0018 End If
0019 Set rs = CurrentDb.OpenRecordset(strQuery)
0020 If rs.EOF Then
0021 Exit Function
0022 Else
0023 rs.MoveFirst
0024 End If
0025 iID_Saved = 0
0026 Do Until rs.EOF
0027 If rs.Fields(1) <> iID_Saved Then
0028 iID_Saved = rs.Fields(1)
0029 strFN_Text_Saved = ""
0030 iFN_ID_Saved = rs.Fields(3)
0031 End If
0032 If rs.Fields(2) <> strFN_Text_Saved Then
0033 strFN_Text_Saved = rs.Fields(2)
0034 iMaster_ID = rs.Fields(3)
0035 iFN_ID_Saved = rs.Fields(3)
0036 Else
0037 iMaster_ID = iFN_ID_Saved
0038 End If
0039 rs.Edit
0040 rs.Fields(4) = iMaster_ID
0041 rs.Update
0042 rs.MoveNext
0043 Loop
0044 Set rs = Nothing
0045 End Function
Line-No. / Ref. Code Line
0001 Public Sub Mark_Duplicate_Footnotes(Optional Note_ID)
0002 Dim strQuery As String
0003 Dim rs As Recordset
0004 Dim iNote_ID As Integer
0005 Dim iNote_ID_Saved As Integer
0006 Dim strFN_Text_Saved As String
0007 Dim iFN_ID_Saved As Integer
0008 Dim iMaster_ID As Integer
0009 If IsMissing(Note_ID) Then
0010 iNote_ID = 0
0011 Else
0012 iNote_ID = Note_ID
0013 End If
0014 If iNote_ID = 0 Then
0015 strQuery = "SELECT Note_Footnotes.Note_ID, Note_Footnotes.FN_Text, Note_Footnotes.FN_ID, Note_Footnotes.Master_ID FROM Note_Footnotes ORDER BY Note_Footnotes.Note_ID, Note_Footnotes.FN_Text, Note_Footnotes.FN_ID;"
0016 Else
0017 strQuery = "SELECT Note_Footnotes.Note_ID, Note_Footnotes.FN_Text, Note_Footnotes.FN_ID, Note_Footnotes.Master_ID FROM Note_Footnotes WHERE (((Note_Footnotes.Note_ID) = " & iNote_ID & ")) ORDER BY Note_Footnotes.FN_Text, Note_Footnotes.FN_ID;"
0018 End If
0019 Set rs = CurrentDb.OpenRecordset(strQuery)
0020 If rs.EOF Then
0021 Exit Sub
0022 Else
0023 rs.MoveFirst
0024 End If
0025 iNote_ID_Saved = 0
0026 Do Until rs.EOF
0027 If rs.Fields(0) <> iNote_ID_Saved Then
0028 iNote_ID_Saved = rs.Fields(0)
0029 strFN_Text_Saved = ""
0030 iFN_ID_Saved = rs.Fields(2)
0031 End If
0032 If rs.Fields(1) <> strFN_Text_Saved Then
0033 strFN_Text_Saved = rs.Fields(1)
0034 iMaster_ID = rs.Fields(2)
0035 iFN_ID_Saved = rs.Fields(2)
0036 Else
0037 iMaster_ID = iFN_ID_Saved
0038 End If
0039 rs.Edit
0040 rs.Fields(3) = iMaster_ID
0041 rs.Update
0042 rs.MoveNext
0043 Loop
0044 Set rs = Nothing
0045 End Sub
Line-No. / Ref. Code Line
0001 Public Function Photo_Copy(strPhotoQuery, Directory_From)
0002 Dim rst As Recordset
0003 Dim db As Database
0004 Dim TransferName As String
0005 Dim strQuery As String
0006 Dim Directory_To As String
0007 Dim FileName_To As String
0008 Dim iBig_Copies As Integer
0009 Dim iSmall_Copies As Integer
0010 Dim fs As Object
0011 Static Error_Decision As String
0012 On Error Resume Next
0013 iBig_Copies = 0
0014 iSmall_Copies = 0
0015 Set fs = CreateObject("Scripting.FileSystemObject")
0016 Set db = CurrentDb
0017 Directory_To = TheoWebsiteRoot & "\Photos\Notes\"
0018 'Check the directories
0019 Debug.Print Directory_From
0020 Debug.Print Directory_To
0021 Stop
0022 strQuery = strPhotoQuery
0023 Set rst = db.OpenRecordset(strQuery)
0024 If Not rst.EOF Then
0025 rst.MoveFirst
0026 End If
0027 Do Until rst.EOF
0028 'Transfer Full JPEG
0029 FileName_To = rst.Fields(1)
0030 TransferName = Directory_To & FileName_To
0031 If Dir(TransferName) = "" Then 'If we already have a file in the transfer directory, then don't copy
0032 fs.CopyFile Directory_From & FileName_To, TransferName 'Copy to the transfer directory
0033 iBig_Copies = iBig_Copies + 1
0034 End If
0035 'Transfer Medium JPEG
0036 FileName_To = rst.Fields(10)
0037 TransferName = Directory_To & FileName_To
0038 If Dir(TransferName) = "" Then 'If we already have a file in the transfer directory, then don't copy
0039 fs.CopyFile Directory_From & FileName_To, TransferName 'Copy to the transfer directory
0040 iSmall_Copies = iSmall_Copies + 1
0041 End If
0042 rst.MoveNext
0043 Loop
0044 Set fs = Nothing
0045 Set rst = Nothing
0046 MsgBox Now() & "; Photo Copy Complete: Large Photos copied = " & iBig_Copies & ". Small Photos copied = " & iSmall_Copies
0047 End Function
Line-No. / Ref. Code Line
0001 Public Function Reference_Note_Links(strText, Calling_Type, Calling_ID, Calling_Timestamp)
0002 Dim x As Long
0003 Dim Y As Long
0004 Dim Note_ID As String
0005 Dim strText_Local As String
0006 Dim strText_End As String
0007 Dim Link_Ref As String
0008 Dim strDirectory As String
0009 Dim strSubDirectory As String
0010 Dim j As Long
0011 Dim TheWord As String
0012 If Len(strText) = 0 Then
0013 Reference_Note_Links = "Not Found"
0014 Exit Function
0015 End If
0016 strText_Local = strText
0017 x = 1
0018 x = InStr(x, strText_Local, "+L")
0019 Reference_Note_Links = "Not Found"
0020 Do While x > 0
0021 Reference_Note_Links = "Found"
0022 Y = InStr(x + 1, strText_Local, "L+")
0023 'Watch out for false positives in finding +L
0024 If Y = 0 Then
0025 x = x + 1
0026 Else
0027 If (Y - x > 10) Or (Y = x + 2) Then
0028 x = x + 1
0029 Else
0030 If Y > Len(strText_Local) - 2 Then
0031 strText_End = ""
0032 Else
0033 strText_End = Mid(strText_Local, Y + 2, Len(strText_Local))
0034 End If
0035 Note_ID = Mid(strText_Local, x + 2, Y - x - 2)
0036 'Find Word
0037 j = FindWord(strText_Local, x, "]")
0038 'Find the key-word(s)
0039 TheWord = Mid(strText_Local, j, x - j)
0040 If Right(TheWord, 1) = "]" Then
0041 TheWord = Mid(TheWord, 2, Len(TheWord) - 2)
0042 End If
0043 'Find Directory & SubDirectory
0044 strSubDirectory = ""
0045 Select Case Calling_Type
0046 Case "N"
0047 strDirectory = "../../Notes/"
0048 strSubDirectory = "Notes_"
0049 Case "NP"
0050 strDirectory = "../../Notes/"
0051 strSubDirectory = "Notes_"
0052 Case "P"
0053 strDirectory = "../../Notes/"
0054 strSubDirectory = "Notes_"
0055 Case "B"
0056 strDirectory = "../../../Notes/"
0057 strSubDirectory = "Notes_"
0058 Case Else
0059 Reference_Note_Links = "Not Found"
0060 Exit Function
0061 End Select
0062 If strSubDirectory <> "" Then
0063 strSubDirectory = strSubDirectory & Val(Mid(Note_ID + 100000, 3, 2)) & "/"
0064 End If
0065 Link_Ref = "" & TheWord & " "
0066 strText_Local = Left(strText_Local, j - 1) & Link_Ref & strText_End
0067 End If
0068 End If
0069 x = InStr(x, strText_Local, "+L")
0070 Loop
0071 strText = strText_Local
0072 End Function
Line-No. / Ref. Code Line
0001 Public Sub Spider_Weblinks_Tester_Summary_Gen()
0002 Dim strOutputFolder As String
0003 Dim strOutputFile As String
0004 Dim strLine As String
0005 Dim FileName As String
0006 Dim FileName_Root As String
0007 Dim strControlQuery As String
0008 Dim rsFooterControl As Recordset
0009 strOutputFolder = TheoWebsiteRoot & "\Test\"
0010 FileName_Root = "WebLinks_Tester_Summary"
0011 FileName = FileName_Root & ".htm"
0012 Set fsoTextFile2 = New FileSystemObject
0013 strOutputFile = strOutputFolder & FileName
0014 Set tsTextFile = fsoTextFile2.CreateTextFile(strOutputFile, True, True)
0015 strLine = ""
0016 tsTextFile.WriteLine strLine
0017 strLine = " "
0018 tsTextFile.WriteLine strLine
0019 strLine = "Theo Todman's Web-Links Test Webpages "
0020 tsTextFile.WriteLine strLine
0021 strLine = " "
0022 tsTextFile.WriteLine strLine
0023 strLine = "Theo Todman's Web-Links Test Webpages "
0024 tsTextFile.WriteLine strLine
0025 strLine = "For lists of External Links from my site,
0026 tsTextFile.WriteLine strLine
0027 strLine = " Follow this Link for a full de-duplicated entry-sequenced list of links, "
0028 tsTextFile.WriteLine strLine
0029 strLine = " Follow this Link for a full entry-sequenced list of links, determined by the Spider, showing the page(s) they are referenced from, "
0030 tsTextFile.WriteLine strLine
0031 strLine = " Follow this Link for another full entry-sequenced list of links, using links found from the WebRefs Mapper, showing the page(s) they are referenced from, "
0032 tsTextFile.WriteLine strLine
0033 strLine = " Follow this Link for a list of all links (as determined by the Spider) for which problems have been detected, ordered by entry sequence within issue-category, and "
0034 tsTextFile.WriteLine strLine
0035 strLine = " Follow this Link for an alternative list of all links (determined by the WebRef Mapper, and omitting composite pages) for which problems have been detected, ordered by entry sequence within issue-category. "
0036 tsTextFile.WriteLine strLine
0037 strLine = " Follow this Link for a list of all links (as determined by the Spider; not yet investigated and flagged as defunct) for which problems have been detected, ordered by entry sequence within issue-category, and "
0038 tsTextFile.WriteLine strLine
0039 strLine = " Follow this Link for an alternative list of all links (determined by the WebRef Mapper, and omitting composite pages; not yet investigated and flagged as defunct) for which problems have been detected, ordered by entry sequence within issue-category. "
0040 tsTextFile.WriteLine strLine
0041 strLine = "I am in the process of using these lists to check the links, correcting (where possible) those that are broken.
"
0042 tsTextFile.WriteLine strLine
0043 'Footer
0044 strLine = "