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 30 (12 items)

cmdArchiveRegen_ClickcmdNotesTableByGroup_ClickFunctor_11Functor_13
Remove_Dummy_RefShuffleDownUnallocatedShuffleDownVolumesShuffleUpVolumes
Fix_Time_Recording_NarrativeSortBooksStartUpWebsite_Tidy

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

Go to top of page



Source Code of: cmdArchiveRegen_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 3

Line-No. / Ref.Code Line
0001Private Sub cmdArchiveRegen_Click()
0002DoCmd.OpenForm ("Notes_Archive_Regen")
0003End Sub

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


Source Code of: cmdNotesTableByGroup_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 76
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Private Sub cmdNotesTableByGroup_Click()
0002Dim x As String
0003Dim rsTableControl As Recordset
0004Dim strMessage As String
0005Dim strQuery As String
0006Dim i As Integer
0007 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Note_Groups.Note_Group, Note_Groups.ID FROM Note_Groups ORDER BY Note_Groups.Note_Group;")
0008strMessage = "Enter Note Group ID: " & Chr(10)
0009rsTableControl.MoveFirst
0010Do While Not rsTableControl.EOF
0011 strMessage = strMessage & Chr(10) & Right(rsTableControl.Fields(1) + 100, 2) & ": " & rsTableControl.Fields(0)
0012 rsTableControl.MoveNext
0013Loop
0014 x = InputBox(strMessage, "Choose a Notes Group")
0015If x = "" Then
0016 Exit Sub
0017End If
0018If Not IsNumeric(x) Then
0019 Exit Sub
0020Else
0021 i = x
0022End If
0023strQuery = ""
0024Select Case i
0025 Case 1
0026 If MsgBox("Do you want to display PI Notes in ascending order of size?", vbYesNo) = vbYes Then
0027 DoCmd.OpenQuery ("Note_Lengths_PI")
0028 Else
0029 DoCmd.OpenQuery ("Notes_PID")
0030 End If
0031 Exit Sub
0032 Case 2
0033 strQuery = "Status"
0034 Case 3
0035 strQuery = "Autobiography"
0036 Case 4
0037 strQuery = "Tractatus"
0038 Case 5
0039 strQuery = "Blog"
0040 Case 6
0041 strQuery = "WriteUp"
0042 Case 7
0043 strQuery = "Bible"
0044 Case 8
0045 strQuery = "Animadversions"
0046 Case 9
0047 strQuery = "Carthusians"
0048 Case 10
0049 strQuery = "Supervisions"
0050 Case 11
0051 strQuery = "Heythrop"
0052 Case 12
0053 strQuery = "Religion"
0054 Case 13
0055 strQuery = "WebDocs"
0056 Case 14
0057 strQuery = "Control"
0058 Case 15
0059 strQuery = "Essays"
0060 Case Else
0061 Exit Sub
0062End Select
0063strQuery = "Notes_" & strQuery
0064DoCmd.OpenQuery (strQuery)
0065If i = 2 Then
0066 DoCmd.OpenTable ("Task_Lists")
0067 DoCmd.OpenTable ("Project_Plans")
0068 DoCmd.OpenTable ("Near_Future_Plans")
0069 DoCmd.OpenTable ("Projects")
0070 DoCmd.OpenTable ("Status_Tasklists")
0071End If
0072If i = 5 Then
0073 DoCmd.OpenTable ("Blog")
0074End If
0075Set rsTableControl = Nothing
0076End Sub

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


Source Code of: Fix_Time_Recording_Narrative
Procedure Type: Public Sub
Module: Testing
Lines of Code: 42
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Fix_Time_Recording_Narrative()
0002Dim strQuery As String
0003Dim rs As Recordset
0004Dim strAbstract As String
0005Dim i As Long
0006Dim j As Long
0007 strQuery = "SELECT Papers.ID, Papers.Author, Papers.Title, Papers.Abstract, Papers.Abstract_Quality, Papers.Write_Up_Note_ID FROM Papers WHERE (((Papers.Abstract) Like ""*This pseudo-Paper is intended as the mechanism to record time spent on the Note *"")) ORDER BY Papers.Author, Papers.Title;"
0008Set rs = CurrentDb.OpenRecordset(strQuery)
0009rs.MoveFirst
0010Do Until rs.EOF
0011 strAbstract = rs.Fields(3)
0012 Debug.Print Now() & " - "; strAbstract
0013 'Fix the abstract
0014 i = InStr(strAbstract, "'")
0015 If i > 0 Then
0016 strAbstract = Left(strAbstract, i) & "[" & Mid(strAbstract, i + 1)
0017 j = InStr(i + 1, strAbstract, "'")
0018 'Check if already fixed!
0019 If j > 0 Then
0020 If InStr(Mid(strAbstract, i, j - i), "++") = 0 Then
0021 strAbstract = Left(strAbstract, j - 1) & "]++" & rs.Fields(5) & "++" & Mid(strAbstract, j) 'Add the note link
0022 'Remove the old link, if necessary
0023 i = InStr(j, strAbstract, "|.|+N")
0024 If i > 0 Then
0025 j = InStr(i + 3, strAbstract, "|.|")
0026 If j > 0 Then
0027 strAbstract = Left(strAbstract, i - 1) & Mid(strAbstract, j)
0028 Else
0029 Stop
0030 End If
0031 End If
0032 Debug.Print Now() & " - "; strAbstract
0033 rs.Edit
0034 rs.Fields(3) = strAbstract
0035 rs.Update
0036 End If
0037 End If
0038 End If
0039 rs.MoveNext
0040Loop
0041Set rs = Nothing
0042End Sub

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


Source Code of: Functor_11
Procedure Type: Public Function
Module: Functors
Lines of Code: 50
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor_11(strQuery, strNote_Text)
0002'Development Log report - Last Quarter Completed Items - Category Sequence
0003Dim rs As Recordset
0004Dim strNote_Text_Local
0005Dim Implementation_Period As String
0006Dim Category As String
0007Dim Development As String
0008Dim Category_Saved As String
0009Dim strCategory_Text As String
0010strNote_Text_Local = ""
0011Category_Saved = "ZZZZZ"
0012strCategory_Text = ""
0013Set rs = CurrentDb.OpenRecordset(strQuery)
0014If Not rs.EOF Then
0015 rs.MoveFirst
0016 Functor_11 = "Yes"
0017Else
0018 Functor_11 = "Yes"
0019 strNote_Text = "|..||.|Nothing to Report.|..|"
0020 Exit Function
0021End If
0022Do Until rs.EOF
0023 Category = rs.Fields(0) & ""
0024 Implementation_Period = rs.Fields(1)
0025 Development = rs.Fields(2) & ""
0026 If Category <> Category_Saved Then
0027 If Category_Saved <> "ZZZZZ" Then
0028 'Finalise Previous Priority
0029 strCategory_Text = "|ii|" & strCategory_Text & "|ii|"
0030 strCategory_Text = "|.|<b>" & Category_Saved & "</b>" & strCategory_Text
0031 End If
0032 'Ready for next Period
0033 strNote_Text_Local = strNote_Text_Local & strCategory_Text
0034 strCategory_Text = ""
0035 End If
0036 strCategory_Text = strCategory_Text & "|1|" & Development
0037 'Move on ...
0038 Category_Saved = Category
0039 rs.MoveNext
0040Loop
0041'Finish the list ...
0042strCategory_Text = "|ii|" & strCategory_Text & "|ii|"
0043strCategory_Text = "|.|<b>" & Category_Saved & "</b>" & strCategory_Text
0044strNote_Text_Local = strNote_Text_Local & strCategory_Text
0045'Top and Tail
0046strNote_Text_Local = "|..|" & strNote_Text_Local & "|..|"
0047'Tidy up
0048Set rs = Nothing
0049strNote_Text = strNote_Text_Local
0050End Function

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


Source Code of: Functor_13
Procedure Type: Public Function
Module: Functors
Lines of Code: 61
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor_13(Note_ID, Note_Title, Note_Text)
0002'Use Form_Documentation_Links to list Buttons referenced in Documenter
0003Dim rs As Recordset
0004Dim strQuery As String
0005Dim Note_Text_Local As String
0006Dim Section_Name As String
0007Dim Section_Name_Saved As String
0008Dim Control_Caption As String
0009Dim Control_Name As String
0010Dim Sections As Boolean
0011 strQuery = "SELECT Form_Documentation_Links.Section FROM Form_Documentation_Links INNER JOIN Form_Controls_Table ON (Form_Documentation_Links.Form_Name = Form_Controls_Table.Form_Name) AND (Form_Documentation_Links.Control_Name = Form_Controls_Table.Control_Name) GROUP BY Form_Documentation_Links.Section, Form_Documentation_Links.Note HAVING (((Form_Documentation_Links.Note) = " & Note_ID & ")) ORDER BY Form_Documentation_Links.Section;"
0012Set rs = CurrentDb.OpenRecordset(strQuery)
0013Sections = False
0014DoEvents
0015If Not rs.EOF Then
0016 rs.MoveLast
0017 If rs.RecordCount > 1 Then
0018 Sections = True
0019 End If
0020End If
0021DoEvents
0022Set rs = Nothing
0023 strQuery = "SELECT Form_Documentation_Links.Section, Form_Controls_Table.Control_Caption, Form_Documentation_Links.Control_Name FROM Form_Documentation_Links INNER JOIN Form_Controls_Table ON (Form_Documentation_Links.Form_Name = Form_Controls_Table.Form_Name) AND (Form_Documentation_Links.Control_Name = Form_Controls_Table.Control_Name) WHERE (((Form_Documentation_Links.Note) = " & Note_ID & ")) ORDER BY Form_Documentation_Links.Section, Form_Controls_Table.Control_Caption;"
0024Set rs = CurrentDb.OpenRecordset(strQuery)
0025If Not rs.EOF Then
0026 rs.MoveFirst
0027Else
0028 Functor_13 = "No"
0029 Exit Function
0030End If
0031If Sections = True Then
0032 Note_Text_Local = "|..|"
0033Else
0034 Note_Text_Local = "|99|"
0035End If
0036Section_Name_Saved = "xxx"
0037Do While Not rs.EOF
0038 Section_Name = rs.Fields(0) & ""
0039 Control_Caption = rs.Fields(1)
0040 Control_Name = rs.Fields(2)
0041 If Sections = True Then
0042 If Section_Name <> Section_Name_Saved Then
0043 If Section_Name_Saved <> "xxx" Then
0044 Note_Text_Local = Note_Text_Local & "|99|"
0045 End If
0046 Note_Text_Local = Note_Text_Local & "|.|<b>" & Section_Name & "</b>|99|"
0047 Section_Name_Saved = Section_Name
0048 End If
0049 End If
0050 Note_Text_Local = Note_Text_Local & "|1|" & Control_Caption & " (+C" & Control_Name & "_ClickC+)"
0051 rs.MoveNext
0052Loop
0053'Finish Off
0054Note_Text_Local = Note_Text_Local & "|99|"
0055If Sections = True Then
0056 Note_Text_Local = Note_Text_Local & "|..|"
0057End If
0058Set rs = Nothing
0059Note_Text = Note_Text_Local
0060Functor_13 = "Yes"
0061End Function

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


Source Code of: Remove_Dummy_Ref
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 5

Line-No. / Ref.Code Line
0001Public Function Remove_Dummy_Ref(strText)
0002'This hardly needs a function, but it's so I can see - via the Documenter - where this replacement is undertaken.
0003'This encoding is used to stop Auto_Reference_Notes from producing spurious links to words or phrases that have the form of Key-Words, but not the meaning: eg. "Sorites" as the name of a journal
0004Remove_Dummy_Ref = Replace(strText, "+XX+", "")
0005End Function

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


Source Code of: ShuffleDownUnallocated
Procedure Type: Public Function
Module: LazyLibrarian
Lines of Code: 7

Line-No. / Ref.Code Line
0001Public Function ShuffleDownUnallocated(i, j)
0002'Only used for setting up the initial random position: tidies up after a volume has been placed on the shelf, ready for the next to be chosen at random
0003Dim k As Long
0004For k = i To j - 1
0005 Unallocated(k) = Unallocated(k + 1)
0006Next k
0007End Function

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


Source Code of: ShuffleDownVolumes
Procedure Type: Public Function
Module: LazyLibrarian
Lines of Code: 7

Line-No. / Ref.Code Line
0001Public Function ShuffleDownVolumes(i, j)
0002'Adjustment required when Volume j is taken from position i (j > i) and placed in position j
0003Dim k As Long
0004For k = i To j - 1
0005 Volume(k) = Volume(k + 1)
0006Next k
0007End Function

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


Source Code of: ShuffleUpVolumes
Procedure Type: Public Function
Module: LazyLibrarian
Lines of Code: 7

Line-No. / Ref.Code Line
0001Public Function ShuffleUpVolumes(i, j)
0002'Adjustment required when Volume i is taken from position j (j > i) and placed in position i
0003Dim k As Long
0004For k = j - 1 To i Step -1
0005 Volume(k + 1) = Volume(k)
0006Next k
0007End Function

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


Source Code of: SortBooks
Procedure Type: Public Sub
Module: LazyLibrarian
Lines of Code: 41
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub SortBooks()
0002Dim i As Long
0003Dim MaxMisSort As Long
0004Dim MisSortChosen As Long
0005Dim volgrabbed As Long
0006Dim Gap As Long
0007MinPlace = 1
0008MaxPlace = Vols
0009FirstVolGrabbed = "No"
0010LastVolGrabbed = "No"
0011StartIteration = Now()
0012Iteration = 0
0013Do While MinPlace < MaxPlace
0014 Iteration = Iteration + 1
0015 'Determine mis-sorts
0016 MaxMisSort = 0
0017 For i = MinPlace To MaxPlace
0018 If Volume(i) <> i Then
0019 MaxMisSort = MaxMisSort + 1
0020 MisSorts(MaxMisSort, 1) = Volume(i)
0021 MisSorts(MaxMisSort, 2) = i
0022 End If
0023 Next i
0024 'Choose a mis-sort
0025 MisSortChosen = Int(Rnd * MaxMisSort) + 1
0026 volgrabbed = MisSorts(MisSortChosen, 1)
0027 Gap = MisSorts(MisSortChosen, 2)
0028 'Make space on the shelf
0029 If volgrabbed > Gap Then
0030 OK = ShuffleDownVolumes(Gap, volgrabbed)
0031 Else
0032 OK = ShuffleUpVolumes(volgrabbed, Gap)
0033 End If
0034 'File the selected book
0035 Volume(volgrabbed) = volgrabbed
0036 'Adjust range
0037 AdjustTheRange
0038Loop
0039EndIteration = Now()
0040TestDuration = (EndIteration - StartIteration) * 24 * 60 * 60
0041End Sub

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


Source Code of: StartUp
Procedure Type: Public Sub
Module: LazyLibrarian
Lines of Code: 14

Line-No. / Ref.Code Line
0001Public Sub StartUp() 'Initialisation
0002Dim i As Long
0003ReDim Unallocated(Vols)
0004ReDim Volume(Vols)
0005ReDim MisSorts(Vols, 2)
0006'Seed the Rnd function
0007Randomize
0008'Populate the Unallocated array with the books
0009For i = 1 To Vols
0010 Unallocated(i) = i
0011Next i
0012'Stack the shelf with randomly-sorted books
0013 RandomiseVolumes
0014End Sub

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


Source Code of: Website_Tidy
Procedure Type: Public Sub
Module: Spider
Lines of Code: 226
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Website_Tidy()
0002Dim rst As Recordset
0003Dim rsLinks As Recordset
0004Dim rsLog As Recordset
0005Dim db As Database
0006Dim Directory As String
0007Dim DatabaseName_Temp As String
0008Dim Directory_Type As String
0009Dim File_Name As String
0010Dim iFileType As Integer
0011Dim iCount As Integer
0012Dim iDeletion_Count As Integer
0013Dim iAction_Count As Integer
0014Dim Last_Regen_Date As Date
0015Dim File_Last_Amended_Date As Date
0016Dim fso As New FileSystemObject
0017Dim f As File
0018Dim strQuery As String
0019Dim NoLinks As String
0020Dim Run_Timestamp As Date
0021Dim strAction As String
0022Dim iCountMax As Integer
0023Dim ConfirmDeletions As Boolean
0024Dim OKToDelete As Boolean
0025If MsgBox("Delete unwanted files from Website?", vbYesNo) <> vbYes Then
0026 Exit Sub
0027End If
0028If MsgBox("Confirm Deletions?", vbYesNo) <> vbYes Then
0029 ConfirmDeletions = False
0030Else
0031 ConfirmDeletions = True
0032End If
0033Set db = CurrentDb
0034iDeletion_Count = 0
0035iAction_Count = 0
0036iCount = 0
0037Run_Timestamp = Now()
0038iCountMax = 5
0039 strQuery = "Select * FROM Website_Tidy_Log WHERE Run_Timestamp > Now();"
0040Set rsLog = db.OpenRecordset(strQuery)
0041 Set rst = db.OpenRecordset("SELECT Site_Map.Full_File_Name, Site_Map.Directory, Site_Map.FIle_Name, Site_Map.File_Timestamp, Site_Map.Size, Site_Map.Timestamp_Logged FROM Site_Map WHERE (((Site_Map.File_Timestamp) < Now() - 20) And ((Right([File_Name], 4)) = "".htm"")) ORDER BY Site_Map.Directory, Site_Map.FIle_Name;")
0042If rst.EOF Then
0043 MsgBox ("Nothing to do")
0044 End
0045End If
0046rst.MoveFirst
0047'Find the Date ...
0048 Set rsLinks = db.OpenRecordset("SELECT * FROM Website_Regen_Latest;") 'Temporary use of wrong rs name!
0049rsLinks.MoveFirst
0050Last_Regen_Date = rsLinks.Fields(0) - 1 'Err on the side of safety
0051Do While Not rst.EOF
0052 DatabaseName_Temp = rst.Fields(0)
0053 Directory = rst.Fields(1) & ""
0054 File_Name = rst.Fields(2)
0055 iFileType = 0
0056 Directory_Type = ""
0057 If Directory = Directory_Type Then
0058 iFileType = 1
0059 End If
0060 Directory_Type = "Acts\"
0061 If Left(Directory, Len(Directory_Type)) = Directory_Type Then
0062 iFileType = 2
0063 End If
0064 Directory_Type = "Bridge\"
0065 If Left(Directory, Len(Directory_Type)) = Directory_Type Then
0066 iFileType = 3
0067 End If
0068 Directory_Type = "Documentation\"
0069 If Left(Directory, Len(Directory_Type)) = Directory_Type Then
0070 iFileType = 4
0071 End If
0072 Directory_Type = "EnigmaEnsemble\"
0073 If Left(Directory, Len(Directory_Type)) = Directory_Type Then
0074 iFileType = 5
0075 End If
0076 Directory_Type = "Petes_PhD"
0077 If Left(Directory, Len(Directory_Type)) = Directory_Type Then
0078 iFileType = 6
0079 End If
0080 Directory_Type = "Photos\"
0081 If Left(Directory, Len(Directory_Type)) = Directory_Type Then
0082 iFileType = 7
0083 End If
0084 Directory_Type = "Sophie_Test\"
0085 If Left(Directory, Len(Directory_Type)) = Directory_Type Then
0086 iFileType = 8
0087 End If
0088 'Exclude Notes_nnn_links
0089 Directory_Type = "Notes\"
0090 If Left(Directory, Len(Directory_Type)) = Directory_Type Then
0091 If Left(File_Name, Len("Notes_")) = "Notes_" And Right(File_Name, Len("_Links.htm")) = "_Links.htm" Then
0092 iFileType = 9
0093 End If
0094 End If
0095 If iFileType = 1 Then
0096 'Exclude various categories ...
0097 If File_Name = "amendmenthistory.htm" Or File_Name = "Artwork.htm" Or File_Name = "BirkbeckPhilSoc.htm" Or File_Name = "Bridge.htm" Or File_Name = "ECBA_Search.htm" Or File_Name = "Electronic_Resources.htm" Or File_Name = "Family.htm" Or File_Name = "index.htm" Or File_Name = ".htm" Then
0098 iFileType = 9
0099 Else
0100 If File_Name = "Bridge_Resume.htm" Or File_Name = "Bridge_Stats_Theo.htm" Or File_Name = "Christians.htm" Or File_Name = "Library_Detail.htm" Or File_Name = ".htm" Or File_Name = "Library_Summary.htm" Or File_Name = "TermPlan08Spring.htm" Or File_Name = "Tetrahedron.htm" Or File_Name = "TT_Search.htm" Or File_Name = "Bridge_Results_Ranking_Bernie_Fri.htm" Then
0101 iFileType = 9
0102 End If
0103 End If
0104 If Left(File_Name, Len("Bridge_Results_Theo")) = "Bridge_Results_Theo" Then
0105 iFileType = 9
0106 End If
0107 If Left(File_Name, Len("c8")) = "c8" Then
0108 iFileType = 9
0109 End If
0110 If Left(File_Name, Len("c9")) = "c9" Then
0111 iFileType = 9
0112 End If
0113 If Left(File_Name, Len("c10")) = "c10" Then
0114 iFileType = 9
0115 End If
0116 If Left(File_Name, Len("commensal")) = "commensal" Then
0117 iFileType = 9
0118 End If
0119 If Left(File_Name, Len("Dud_")) = "Dud_" Then
0120 iFileType = 9
0121 End If
0122 If Left(File_Name, Len("obt")) = "obt" Then
0123 iFileType = 9
0124 End If
0125 If Left(File_Name, Len("oh")) = "oh" Then
0126 iFileType = 9
0127 End If
0128 If Left(File_Name, Len("pdg")) = "pdg" Then
0129 iFileType = 9
0130 End If
0131 If Left(File_Name, Len("phil")) = "phil" Then
0132 iFileType = 9
0133 End If
0134 If Left(File_Name, Len("SiteMap")) = "SiteMap" Then
0135 iFileType = 9
0136 End If
0137 If Left(File_Name, Len("totl")) = "totl" Then
0138 iFileType = 9
0139 End If
0140 If Left(File_Name, Len("tract")) = "tract" Then
0141 iFileType = 9
0142 End If
0143 If Left(File_Name, Len("vb")) = "vb" Then
0144 iFileType = 9
0145 End If
0146 If Left(File_Name, Len("web")) = "web" Then
0147 iFileType = 9
0148 End If
0149 End If
0150 If iFileType < 2 Then
0151 If Dir(DatabaseName_Temp) <> "" Then
0152 Set f = fso.GetFile(DatabaseName_Temp)
0153 File_Last_Amended_Date = f.DateLastModified
0154 If File_Last_Amended_Date < Last_Regen_Date Then
0155 strQuery = "SELECT Raw_Links.Raw_Link, Raw_Links.Timestamp_Logged, Raw_Links.Link_Type FROM Raw_Links WHERE (((Raw_Links.Raw_Link) = """ & File_Name & """) And ((Raw_Links.Link_Type) <> ""Same Page"")) ORDER BY Raw_Links.Timestamp_Logged DESC;"
0156 Set rsLinks = db.OpenRecordset(strQuery)
0157 If rsLinks.EOF Then
0158 NoLinks = "No Links"
0159 Else
0160 NoLinks = "Links Exist"
0161 rsLinks.MoveFirst
0162 If rsLinks.Fields(1) < Last_Regen_Date Then
0163 NoLinks = NoLinks & " (Old Links Only)"
0164 Else
0165 NoLinks = NoLinks & " (Contains a Recent Link)"
0166 End If
0167 End If
0168 If ConfirmDeletions = True Then
0169 If MsgBox("Delete " & File_Name & " (" & File_Last_Amended_Date & "). " & NoLinks & Chr(10) & "Full path: " & DatabaseName_Temp, vbYesNo + vbDefaultButton1) = vbYes Then
0170 OKToDelete = True
0171 Else
0172 OKToDelete = False
0173 End If
0174 Else
0175 OKToDelete = True
0176 iCountMax = 100
0177 End If
0178 If OKToDelete = True Then
0179 iDeletion_Count = iDeletion_Count + 1
0180 Debug.Print Now() & " - " & iAction_Count & " - " & DatabaseName_Temp & ". " & NoLinks
0181 If Dir(DatabaseName_Temp) <> "" Then
0182 Kill DatabaseName_Temp
0183 Debug.Print Now() & " - " & iAction_Count & " - " & DatabaseName_Temp & ". Deleted!"
0184 strAction = "File Deleted"
0185 Else
0186 Debug.Print Now() & " - " & iAction_Count & " - " & DatabaseName_Temp & ". Item already deleted!"
0187 strAction = "File Not Found"
0188 Stop
0189 End If
0190 Else
0191 strAction = "Not Deleted"
0192 End If
0193 iAction_Count = iAction_Count + 1
0194 rsLog.AddNew
0195 rsLog.Fields(0) = Run_Timestamp
0196 rsLog.Fields(1) = iAction_Count
0197 rsLog.Fields(2) = File_Name
0198 rsLog.Fields(3) = DatabaseName_Temp
0199 rsLog.Fields(4) = File_Last_Amended_Date
0200 rsLog.Fields(5) = NoLinks
0201 rsLog.Fields(6) = strAction
0202 rsLog.Fields(7) = Now()
0203 rsLog.Update
0204 'Delete associated raw links from this file
0205 OK = Prune_Raw_Links(Replace(DatabaseName_Temp, File_Name, ""), File_Name)
0206 iCount = iCount + 1
0207 If iCount > iCountMax Then
0208 If MsgBox("Stop Run?", vbYesNo + vbDefaultButton2) = vbYes Then
0209 MsgBox (Now() & " - Run stopped: " & iDeletion_Count & " unwanted files deleted from Website")
0210 DoCmd.OpenTable ("Website_Tidy_Log")
0211 End
0212 End If
0213 iCount = 0
0214 End If
0215 End If
0216 End If
0217 End If
0218 rst.MoveNext
0219Loop
0220Set rsLog = Nothing
0221Set rst = Nothing
0222Set rsLinks = Nothing
0223Set fso = Nothing
0224 DoCmd.OpenTable ("Website_Tidy_Log")
0225MsgBox (Now() & " - " & iDeletion_Count & " unwanted files deleted from Website")
0226End Sub

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


© Theo Todman, June 2007 - March 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