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 29 (10 items)

cmdTimelines_ClickFunctor_14Mark_Duplicate_Abstract_FootnotesPhoto_Copy
Reference_Note_LinksCode_ArchiveFull_Link_Same_Directory_GenMark_Duplicate_Footnotes
Spider_Weblinks_Tester_Summary_GenWebRefs_Checker_Pages_Gen..

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

Go to top of page



Source Code of: cmdTimelines_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 159
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Private Sub cmdTimelines_Click()
0002Dim x As String
0003Dim strMessage As String
0004Dim strQuery As String
0005Dim i As Integer
0006Dim strPhotoQuery As String
0007Dim strPhotoType As String
0008Dim Directory_From As String
0009 strMessage = "Update and / or output a Timeline page? Choose from the numeric options below:-" & Chr(10)
0010strMessage = strMessage & Chr(10) & "01. Blog"
0011strMessage = strMessage & Chr(10) & "02. Coxes Farm Timeline"
0012strMessage = strMessage & Chr(10) & "03. Coxes Farm (Repairs) Photo List"
0013strMessage = strMessage & Chr(10) & "04. Coxes Farm (Pre-Repairs) Photo List"
0014strMessage = 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"
0017strMessage = strMessage & Chr(10) & "08. Correct inconsistent Photo_Types"
0018 x = InputBox(strMessage, "Choose a Timeline Option", 8)
0019If x = "" Then
0020 MsgBox ("Request omitted; try again")
0021 Exit Sub
0022End If
0023If Not IsNumeric(x) Then
0024 MsgBox ("Request not numeric; try again")
0025 Exit Sub
0026Else
0027 i = x
0028End If
0029If i > 8 Or i < 1 Then
0030 MsgBox ("Request out of range; try again")
0031 Exit Sub
0032End If
0033If 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
0050End If
0051If 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
0069End If
0070If 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?"
0075End If
0076If 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?"
0081End If
0082If 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?"
0087End If
0088If 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
0106End If
0107If 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
0119End If
0120If 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
0132End If
0133If 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
0145End If
0146If i = 6 Then
0147 DoCmd.OpenQuery ("Search_Photos_Raw")
0148End If
0149If 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")
0153End If
0154If 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")
0158End If
0159End Sub

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


Source Code of: Code_Archive
Procedure Type: Public Sub
Module: Documentation
Lines of Code: 9

Line-No. / Ref.Code Line
0001Public 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?
0009End Sub

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


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

Line-No. / Ref.Code Line
0001Public Sub Full_Link_Same_Directory_Gen()
0002Dim rst As Recordset
0003Dim db As Database
0004Dim strQuery As String
0005Dim Directory As String
0006Dim Full_Link As String
0007Dim iRecords_Read As Long
0008DoCmd.SetWarnings (False)
0009Set db = CurrentDb
0010iRecords_Read = 1
0011Do While iRecords_Read > 0
0012 iRecords_Read = 0
0013 strQuery = "SELECT Raw_Links.* FROM Raw_Links;"
0014 Set rst = db.OpenRecordset(strQuery)
0015 If Not rst.EOF Then
0016 rst.MoveFirst
0017 Do While Not rst.EOF
0018 If (rst.Fields(5) = "Same Directory") Then
0019 If (rst.Fields(3) & "" = "") Then
0020 Directory = rst.Fields(0).Value
0021 Full_Link = Directory & Replace(rst.Fields(2).Value, "/", "\")
0022 rst.Edit
0023 rst.Fields(3) = Full_Link
0024 rst.Update
0025 iRecords_Read = iRecords_Read + 1
0026 If iRecords_Read > 200000 Then
0027 DoEvents
0028 rst.MoveLast
0029 DoEvents
0030 End If
0031 End If
0032 End If
0033 rst.MoveNext
0034 Loop
0035 If iRecords_Read > 200000 Then
0036 Set rst = Nothing
0037 'Compact & repair ...
0038 Compact_Repair ("C:\Theo's Files\Birkbeck\Web_Generator_Performance")
0039 iRecords_Read = 1
0040 End If
0041 End If
0042Loop
0043End Sub

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


Source Code of: Functor_14
Procedure Type: Public Function
Module: Functors
Lines of Code: 68
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor_14(Note_ID, Note_Title, Note_Text)
0002'Create an HTML table for the Blog
0003Dim rs As Recordset
0004Dim rsNotes As Recordset
0005Dim strQuery As String
0006Dim Note_Text_Local As String
0007Dim strLink As String
0008Dim strControlQuery As String
0009Dim strPrefix As String
0010Dim strPrintLinkPrefix As String
0011Dim i As Integer
0012Dim iMax As Integer
0013 strQuery = "SELECT Blog.Item_Date, Blog.Item_Title, Blog.Item_Topic, Blog.Note_1, Blog.Note_2, Blog.Note_3, Blog.Note_4 FROM Blog ORDER BY Blog.Item_Date DESC , Blog.Item_Title;"
0014Set rs = CurrentDb.OpenRecordset(strQuery)
0015If Not rs.EOF Then
0016 rs.MoveFirst
0017Else
0018 Functor_14 = "No"
0019 Exit Function
0020End If
0021'Create Table Header
0022Note_Text_Local = "<br><CENTER><TABLE class = ""ReadingList"" WIDTH=950><TR><TD class = ""BridgeLeft"" WIDTH=""15%""> <B>Date</B></TD><TD class = ""BridgeLeft"" WIDTH=""70%""> <B>Topic</B></TD><TD class = ""BridgeLeft"" WIDTH=""15%""> <B>Reference</B></TD></TR>"
0023strPrefix = "<br>&rarr; "
0024'Add rows to table
0025Do Until rs.EOF
0026 Note_Text_Local = Note_Text_Local & "<TR><TD class = ""BridgeLeft"" WIDTH=""15%"">" & Day(rs.Fields(0)) & " " & MonthName(Month(rs.Fields(0))) & " " & Year(rs.Fields(0))
0027 Note_Text_Local = Note_Text_Local & "</TD><TD class = ""BridgeLeft"" WIDTH=""70%""><b>" & rs.Fields(1) & ": </b>" & rs.Fields(2)
0028 If rs.Fields(4) = 0 Then
0029 iMax = 1
0030 Else
0031 If rs.Fields(5) = 0 Then
0032 iMax = 2
0033 Else
0034 If rs.Fields(6) = 0 Then
0035 iMax = 3
0036 Else
0037 iMax = 4
0038 End If
0039 End If
0040 End If
0041 strLink = ""
0042 For i = 1 To iMax
0043 If iMax > 1 Then
0044 strLink = strLink & IIf(i > 1, "<br><br>", "") & "Part " & i & "<br>&rarr; "
0045 End If
0046 strLink = strLink & "Note++" & rs.Fields(2 + i) & "++"
0047 strControlQuery = "Select Notes_To_Print.* FROM Notes_To_Print WHERE (Notes_To_Print.Note_ID = " & rs.Fields(2 + i) & " AND Notes_To_Print.Current=True) ORDER BY Notes_To_Print.Max_Depth, Notes_To_Print.Print_ReadingList;"
0048 Set rsNotes = CurrentDb.OpenRecordset(strControlQuery)
0049 If Not rsNotes.EOF Then
0050 strPrintLinkPrefix = "../../Notes/Notes_" & Val(Mid(rs.Fields(2 + i) + 100000, 3, 2)) & "/"
0051 rsNotes.MoveFirst
0052 Do While Not rsNotes.EOF
0053 strLink = strLink & strPrefix & "<A Href=""" & strPrintLinkPrefix & "Notes_Print/NotesPrint_" & rsNotes.Fields(0) & "_" & rsNotes.Fields(1) & IIf(rsNotes.Fields(2) & "" = "Yes", "_P", "") & IIf(rsNotes.Fields(3) = "Yes", "_R", "") & ".htm"" TARGET = ""_top"">Printable</A> (L" & rsNotes.Fields(1).Value & IIf(rsNotes.Fields(3).Value = "Yes", ", R", "") & ")"
0054 rsNotes.MoveNext
0055 Loop
0056 End If
0057 Next i
0058 Note_Text_Local = Note_Text_Local & "</TD><TD class = ""BridgeLeft"" WIDTH=""15%"">" & strLink
0059 Note_Text_Local = Note_Text_Local & "</TD></TR>"
0060 rs.MoveNext
0061Loop
0062'Add Table Footer
0063Note_Text_Local = Note_Text_Local & "</TABLE></CENTER>"
0064Note_Text = Note_Text_Local
0065Functor_14 = "Yes"
0066Set rs = Nothing
0067Set rsNotes = Nothing
0068End Function

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


Source Code of: Mark_Duplicate_Abstract_Footnotes
Procedure Type: Public Function
Module: Testing
Lines of Code: 45
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Mark_Duplicate_Abstract_Footnotes(strType, Optional ID)
0002Dim strQuery As String
0003Dim rs As Recordset
0004Dim iID As Integer
0005Dim iID_Saved As Integer
0006Dim strFN_Text_Saved As String
0007Dim iFN_ID_Saved As Integer
0008Dim iMaster_ID As Integer
0009If IsMissing(ID) Then
0010 iID = 0
0011Else
0012 iID = ID
0013End If
0014If 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;"
0016Else
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;"
0018End If
0019Set rs = CurrentDb.OpenRecordset(strQuery)
0020If rs.EOF Then
0021 Exit Function
0022Else
0023 rs.MoveFirst
0024End If
0025iID_Saved = 0
0026Do 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
0043Loop
0044Set rs = Nothing
0045End Function

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


Source Code of: Mark_Duplicate_Footnotes
Procedure Type: Public Sub
Module: Testing
Lines of Code: 45
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Mark_Duplicate_Footnotes(Optional Note_ID)
0002Dim strQuery As String
0003Dim rs As Recordset
0004Dim iNote_ID As Integer
0005Dim iNote_ID_Saved As Integer
0006Dim strFN_Text_Saved As String
0007Dim iFN_ID_Saved As Integer
0008Dim iMaster_ID As Integer
0009If IsMissing(Note_ID) Then
0010 iNote_ID = 0
0011Else
0012 iNote_ID = Note_ID
0013End If
0014If 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;"
0016Else
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;"
0018End If
0019Set rs = CurrentDb.OpenRecordset(strQuery)
0020If rs.EOF Then
0021 Exit Sub
0022Else
0023 rs.MoveFirst
0024End If
0025iNote_ID_Saved = 0
0026Do 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
0043Loop
0044Set rs = Nothing
0045End Sub

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


Source Code of: Photo_Copy
Procedure Type: Public Function
Module: Timelines
Lines of Code: 47
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Photo_Copy(strPhotoQuery, Directory_From)
0002Dim rst As Recordset
0003Dim db As Database
0004Dim TransferName As String
0005Dim strQuery As String
0006Dim Directory_To As String
0007Dim FileName_To As String
0008Dim iBig_Copies As Integer
0009Dim iSmall_Copies As Integer
0010Dim fs As Object
0011Static Error_Decision As String
0012On Error Resume Next
0013iBig_Copies = 0
0014iSmall_Copies = 0
0015Set fs = CreateObject("Scripting.FileSystemObject")
0016Set db = CurrentDb
0017Directory_To = TheoWebsiteRoot & "\Photos\Notes\"
0018'Check the directories
0019Debug.Print Directory_From
0020Debug.Print Directory_To
0021Stop
0022strQuery = strPhotoQuery
0023Set rst = db.OpenRecordset(strQuery)
0024If Not rst.EOF Then
0025 rst.MoveFirst
0026End If
0027Do 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
0043Loop
0044Set fs = Nothing
0045Set rst = Nothing
0046MsgBox Now() & "; Photo Copy Complete: Large Photos copied = " & iBig_Copies & ". Small Photos copied = " & iSmall_Copies
0047End Function

Procedures Calling This Procedure (Photo_Copy) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page


Source Code of: Reference_Note_Links
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 72
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Reference_Note_Links(strText, Calling_Type, Calling_ID, Calling_Timestamp)
0002Dim x As Long
0003Dim Y As Long
0004Dim Note_ID As String
0005Dim strText_Local As String
0006Dim strText_End As String
0007Dim Link_Ref As String
0008Dim strDirectory As String
0009Dim strSubDirectory As String
0010Dim j As Long
0011Dim TheWord As String
0012If Len(strText) = 0 Then
0013 Reference_Note_Links = "Not Found"
0014 Exit Function
0015End If
0016strText_Local = strText
0017x = 1
0018x = InStr(x, strText_Local, "+L")
0019Reference_Note_Links = "Not Found"
0020Do 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 = "<A HREF = """ & strDirectory & strSubDirectory & "Notes_" & Note_ID & "_Links.htm"">" & TheWord & "</A>"
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")
0070Loop
0071strText = strText_Local
0072End Function

Procedures Calling This Procedure (Reference_Note_Links) Procedures Called By This Procedure (Reference_Note_Links) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page


Source Code of: Spider_Weblinks_Tester_Summary_Gen
Procedure Type: Public Sub
Module: Spider
Lines of Code: 60
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Spider_Weblinks_Tester_Summary_Gen()
0002Dim strOutputFolder As String
0003Dim strOutputFile As String
0004Dim strLine As String
0005Dim FileName As String
0006Dim FileName_Root As String
0007Dim strControlQuery As String
0008Dim rsFooterControl As Recordset
0009strOutputFolder = TheoWebsiteRoot & "\Test\"
0010FileName_Root = "WebLinks_Tester_Summary"
0011FileName = FileName_Root & ".htm"
0012Set fsoTextFile2 = New FileSystemObject
0013strOutputFile = strOutputFolder & FileName
0014Set tsTextFile = fsoTextFile2.CreateTextFile(strOutputFile, True, True)
0015strLine = "<!DOCTYPE html><HTML lang=""en"">"
0016tsTextFile.WriteLine strLine
0017strLine = "<HEAD><meta charset=""utf-8"">"
0018tsTextFile.WriteLine strLine
0019strLine = "<TITLE>Theo Todman's Web-Links Test Webpages</TITLE>"
0020tsTextFile.WriteLine strLine
0021strLine = "<link href=""../TheosStyle.css"" rel=""stylesheet"" type=""text/css""><link rel=""shortcut icon"" href=""../TT_ICO.png"" /></HEAD><BODY>"
0022tsTextFile.WriteLine strLine
0023strLine = "<H1>Theo Todman's Web-Links Test Webpages</H1>"
0024tsTextFile.WriteLine strLine
0025strLine = "<p>For <b>lists of External Links</b> from my site, </p><ul type=""disc"">"
0026tsTextFile.WriteLine strLine
0027strLine = "<li>Follow <A HREF = ""WebLinks_Tester_Brief.htm"">this Link</A> for a full de-duplicated entry-sequenced list of links, </li>"
0028tsTextFile.WriteLine strLine
0029strLine = "<li>Follow <A HREF = ""WebLinks_Tester_Full.htm"">this Link</A> for a full entry-sequenced list of links, determined by the Spider, showing the page(s) they are referenced from, </li>"
0030tsTextFile.WriteLine strLine
0031strLine = "<li>Follow <A HREF = ""WebLinks_Tester_Full_Map.htm"">this Link</A> for another full entry-sequenced list of links, using links found from the WebRefs Mapper, showing the page(s) they are referenced from, </li>"
0032tsTextFile.WriteLine strLine
0033strLine = "<li>Follow <A HREF = ""WebLinks_Tester.htm"">this Link</A> 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 </li>"
0034tsTextFile.WriteLine strLine
0035strLine = "<li>Follow <A HREF = ""WebLinks_Tester_Map.htm"">this Link</A> 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. </li>"
0036tsTextFile.WriteLine strLine
0037strLine = "<li>Follow <A HREF = ""WebLinks_Tester_NotDefunct.htm"">this Link</A> 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 </li>"
0038tsTextFile.WriteLine strLine
0039strLine = "<li>Follow <A HREF = ""WebLinks_Tester_Map_NotDefunct.htm"">this Link</A> 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. </li></ul>"
0040tsTextFile.WriteLine strLine
0041strLine = "<p>I am in the process of using these lists to check the links, correcting (where possible) those that are broken.</p>"
0042tsTextFile.WriteLine strLine
0043'Footer
0044strLine = "</TABLE><BR>"
0045tsTextFile.WriteLine strLine
0046'Page Footer
0047strLine = ""
0048strControlTable = "WebLinkCheck_Ctrl"
0049 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;"
0050Set rsFooterControl = CurrentDb.OpenRecordset(strControlQuery)
0051rsFooterControl.MoveFirst
0052Do While Not rsFooterControl.EOF
0053 strLine = strLine & rsFooterControl.Fields(0)
0054 OK = Replace_Timestamp(strLine)
0055 rsFooterControl.MoveNext
0056Loop
0057tsTextFile.WriteLine strLine
0058 OK = CopyToTransfer(strOutputFolder, FileName)
0059Set tsTextFile = Nothing
0060End Sub

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


Source Code of: WebRefs_Checker_Pages_Gen
Procedure Type: Public Sub
Module: Testing
Lines of Code: 11

Line-No. / Ref.Code Line
0001Public Sub WebRefs_Checker_Pages_Gen()
0002 OK = ZapFiles(TheoWebsiteRoot & "\Test", "WebLinks_Tester")
0003 Spider_WebLinks_Tester_Brief_Page_Gen
0004 Spider_WebLinks_Tester_Page_Gen
0005 Spider_WebLinks_Tester_Page_Full_Gen
0006 Spider_WebLinks_Tester_Page_Gen ("Map")
0007 Spider_WebLinks_Tester_Page_Full_Gen ("Map")
0008 OK = Spider_WebLinks_Tester_Page_Gen(, "NotDefunct")
0009 OK = Spider_WebLinks_Tester_Page_Gen("Map", "NotDefunct")
0010 Spider_Weblinks_Tester_Summary_Gen
0011End Sub

Procedures Calling This Procedure (WebRefs_Checker_Pages_Gen) Procedures Called By This Procedure (WebRefs_Checker_Pages_Gen) Go To Top of This Page
Link to VBA Code Control Page


© Theo Todman, June 2007 - Sept 2023. 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