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 19 (7 items)

Backup_Prune_ScurryFunctorMap_WebRefs_MapperFlag_For_Deletion
Map_WebRefsMonthly_ReportingTest_It.

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

Go to top of page



Source Code of: Backup_Prune_Scurry
Procedure Type: Public Function
Module: Backups
Lines of Code: 89
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Backup_Prune_Scurry(DirectoryName, Directory_Timestamp, DirectoryLevel_In, Backup_Database, Directory_Only)
0002Dim rst As Recordset
0003Dim rst2 As Recordset
0004Dim db As Database
0005Dim OK As String
0006Dim fso As FileSystemObject
0007Dim Directory_Out As String
0008Dim MainFolder
0009Dim FileCollection
0010Dim File
0011Dim File_Name As String
0012Dim DirectoryLevel As Integer
0013Dim File_Timestamp As Date
0014Dim File_Wanted As String
0015Dim No_Backup_Now
0016Dim No_Backup_Later
0017Dim Response
0018Dim SiteMapDirectory As String
0019Dim Directory_Timestamp_Local
0020'This is a recursive Sub - ie. it calls itself
0021Backup_Prune_Scurry = "OK"
0022If InStr(DirectoryName, "$") > 0 Or InStr(DirectoryName, "D:\System Volume Information\") > 0 Then
0023 GoTo Exit_Sub
0024End If
0025DirectoryLevel = DirectoryLevel_In + 1
0026Directories_Logged = Directories_Logged + 1
0027Set db = CurrentDb
0028'Write out a record (to Full_Backup_Directory_Structure_Temp) for each sub-directory
0029 Set rst2 = db.OpenRecordset("SELECT Full_Backup_Directory_Structure_Temp.* FROM Full_Backup_Directory_Structure_Temp;")
0030Directory_ID = Directory_ID + 1
0031rst2.AddNew
0032rst2.Fields(0) = Directory_ID
0033rst2.Fields(1) = DirectoryName
0034rst2.Fields(2) = DirectoryLevel
0035rst2.Fields(3) = Now()
0036rst2.Fields(4) = Directory_Timestamp
0037rst2.Update
0038Set rst2 = Nothing
0039Set fso = CreateObject("Scripting.FileSystemObject")
0040If (Now() - Time_Start_Old) * 24 > 0.25 Then
0041 Compact_Repair (Backup_Database)
0042 Time_Start_Old = Now()
0043 Files_Logged = 0
0044Else
0045 If Directory_Only = False Then
0046 If Files_Logged > 200000 Then
0047 Files_Logged = 0
0048 Compact_Repair (Backup_Database)
0049 End If
0050 End If
0051End If
0052Set MainFolder = fso.GetFolder(DirectoryName)
0053If Directory_Only = False Then
0054 Set FileCollection = MainFolder.Files
0055 Set rst2 = db.OpenRecordset("SELECT Full_Backup_Site_Map_Temp.* FROM Full_Backup_Site_Map_Temp;")
0056 'Main Folders
0057 On Error Resume Next
0058 For Each File In FileCollection
0059 File_Wanted = "Yes"
0060 File_Name = File.Name
0061 File_Timestamp = File.DateLastModified
0062 'Log file stats
0063 SiteMapDirectory = DirectoryName
0064 rst2.AddNew
0065 rst2.Fields(0) = File_Name
0066 rst2.Fields(1) = File.Size
0067 rst2.Fields(2) = File_Timestamp
0068 rst2.Fields(3) = Directory_ID
0069 rst2.Update
0070 Files_Processed = Files_Processed + 1
0071 Files_Logged = Files_Logged + 1
0072 Next File
0073 Set rst2 = Nothing
0074End If
0075Recursion:
0076Set FileCollection = MainFolder.SubFolders
0077For Each File In FileCollection
0078 File_Name = File.Name
0079 Directory_Timestamp_Local = File.DateLastModified
0080 Directory_Out = DirectoryName & File_Name & "\"
0081 'Recursion ...
0082 OK = Backup_Prune_Scurry(Directory_Out, Directory_Timestamp_Local, DirectoryLevel, Backup_Database, Directory_Only)
0083Next File
0084Exit_Sub:
0085Set rst2 = Nothing
0086Set rst = Nothing
0087Set MainFolder = Nothing
0088Set FileCollection = Nothing
0089End Function

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


Source Code of: Flag_For_Deletion
Procedure Type: Public Sub
Module: Backups
Lines of Code: 73
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Flag_For_Deletion()
0002Dim rst2 As Recordset
0003Dim db As Database
0004Dim Start_Time As Date
0005Dim Files_Processed As Long
0006Dim Files_Logged As Long
0007Dim File_Name As String
0008Dim File_Name_Saved As String
0009Dim File_Size As Long
0010Dim File_Size_Saved As Long
0011Dim MaxLocks As Long
0012Dim LocksCount As Long
0013Dim Space_Saved As Double
0014Dim strMsg As String
0015Dim Run_Duration As Single
0016Dim Run_Duration_Text As String
0017Dim File_Timestamp As Date
0018Dim File_Timestamp_Saved As Date
0019Set db = CurrentDb
0020Start_Time = Now()
0021MaxLocks = 5000
0022Files_Processed = 0
0023Files_Logged = 0
0024File_Name_Saved = ""
0025File_Size_Saved = 0
0026File_Timestamp_Saved = 0
0027LocksCount = 0
0028Space_Saved = 0
0029 DoCmd.RunSQL ("UPDATE Full_Backup_Site_Map_Temp SET Full_Backup_Site_Map_Temp.[Delete_Failed?] = False WHERE (((Full_Backup_Site_Map_Temp.[Delete_Failed?])=True));")
0030 Set rst2 = db.OpenRecordset("SELECT Full_Backup_Site_Map_Temp.File_Name, Full_Backup_Site_Map_Temp.Size, Full_Backup_Site_Map_Temp.File_Timestamp, Full_Backup_Directory_Structure_Temp.Directory_Timestamp, Full_Backup_Site_Map_Temp.Directory, Full_Backup_Site_Map_Temp.[Delete?] FROM Full_Backup_Directory_Structure_Temp INNER JOIN Full_Backup_Site_Map_Temp ON Full_Backup_Directory_Structure_Temp.Directory = Full_Backup_Site_Map_Temp.Directory WHERE Full_Backup_Site_Map_Temp.[Delete?] = False ORDER BY Full_Backup_Site_Map_Temp.File_Name, Full_Backup_Site_Map_Temp.Size, Full_Backup_Site_Map_Temp.File_Timestamp, Full_Backup_Directory_Structure_Temp.Directory_Timestamp;")
0031rst2.MoveFirst
0032DBEngine.BeginTrans
0033Do Until rst2.EOF
0034 Files_Processed = Files_Processed + 1
0035 File_Name = rst2.Fields(0)
0036 File_Size = rst2.Fields(1)
0037 File_Timestamp = rst2.Fields(2)
0038 If (File_Name_Saved = File_Name) And (File_Size_Saved = File_Size) And (File_Timestamp_Saved = File_Timestamp) Then
0039 Files_Logged = Files_Logged + 1
0040 LocksCount = LocksCount + 1
0041 Space_Saved = Space_Saved + File_Size
0042 rst2.Edit
0043 rst2.Fields(5) = True
0044 rst2.Update
0045 If LocksCount > MaxLocks Then
0046 DBEngine.CommitTrans
0047 LocksCount = 0
0048 DBEngine.BeginTrans
0049 End If
0050 End If
0051 File_Name_Saved = File_Name
0052 File_Size_Saved = File_Size
0053 File_Timestamp_Saved = File_Timestamp
0054 rst2.MoveNext
0055Loop
0056If LocksCount > 0 Then
0057 DBEngine.CommitTrans
0058End If
0059Set rst2 = Nothing
0060Run_Duration = Now() - Start_Time
0061Run_Duration = Run_Duration * 24
0062If Run_Duration < 1 Then
0063 Run_Duration_Text = Round(Run_Duration * 60, 2) & " minutes"
0064Else
0065 Run_Duration_Text = Round(Run_Duration, 2) & " hours"
0066End If
0067If automatic_processing <> "Yes" Then
0068 strMsg = "Deletion Flagging completed at " & Now() & " in " & Run_Duration_Text & "."
0069 strMsg = strMsg & Chr$(10) & "Files processed = " & Files_Processed & "."
0070 strMsg = strMsg & Chr$(10) & "Files Flagged for Deletion = " & Files_Logged & ". Space saved = " & Round(Space_Saved / 1000000, 1) & "Mb."
0071 MsgBox (strMsg)
0072End If
0073End Sub

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


Source Code of: Functor
Procedure Type: Public Function
Module: Functors
Lines of Code: 221
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor(Note_ID, Note_Title, Note_Text)
0002Dim i As Long
0003Dim j As Long
0004Dim m As Long
0005Dim n As Long
0006Dim p As Long
0007Dim q As Long
0008Dim Note_Text_Local As String
0009Dim strStart_Comment As String
0010Dim strEnd_Comment As String
0011Dim strFunctor_ID As String
0012Dim strFunctor_ID_Plus_Parameters As String
0013Dim Dud_Functor As Boolean
0014Dim Functor_Insert As String
0015Dim Functor_Insert_2 As String
0016Dim OK_Local As String
0017Dim strYear As String
0018Dim strQuarter As String
0019Dim strQuarter_Check As String
0020Dim strQuery As String
0021Dim strQuery_2 As String
0022Dim rst As Recordset
0023Dim str_Functor_Parameter As String
0024Dim str_Functor_Parameter_2 As String
0025Dim str_Functor_Parameter_3 As String
0026strStart_Comment = "<!-- FUNCTOR_ID="
0027m = Len(strStart_Comment)
0028strEnd_Comment = "<!-- FUNCTOR_END"
0029Note_Text_Local = Note_Text
0030Functor = "No"
0031'Find the comment with instructions!
0032i = InStr(Note_Text_Local, strStart_Comment)
0033If i = 0 Then
0034 Functor = "Nothing to Do"
0035 Exit Function
0036End If
0037Do While i > 0
0038 str_Functor_Parameter = ""
0039 str_Functor_Parameter_2 = ""
0040 str_Functor_Parameter_3 = ""
0041 'Process the Functor ... find the ID
0042 n = InStr(i, Note_Text_Local, "-->")
0043 If n = 0 Then
0044 'End tag not found
0045 Debug.Print Now() & " - "; "Functor: End-tag for ID missing. Note="; Note_ID
0046 Else
0047 strFunctor_ID_Plus_Parameters = Trim(Mid(Note_Text_Local, i + m, n - i - m))
0048 'Check for Parameter
0049 p = InStr(strFunctor_ID_Plus_Parameters, ",")
0050 If p > 0 Then
0051 'Check for Second Parameter
0052 strFunctor_ID = Trim(Left(strFunctor_ID_Plus_Parameters, p - 1))
0053 q = InStr(p + 1, strFunctor_ID_Plus_Parameters, ",")
0054 If q > 0 Then
0055 str_Functor_Parameter = Trim(Mid(strFunctor_ID_Plus_Parameters, p + 1, q - p - 1))
0056 str_Functor_Parameter_2 = Trim(Mid(strFunctor_ID_Plus_Parameters, q + 1))
0057 'Check for Third Parameter (or, currently, a helpful comment)
0058 q = InStr(str_Functor_Parameter_2, ",")
0059 If q > 0 Then
0060 str_Functor_Parameter_3 = Trim(Mid(str_Functor_Parameter_2, q + 1))
0061 str_Functor_Parameter_2 = Trim(Left(str_Functor_Parameter_2, q - 1))
0062 End If
0063 Else
0064 str_Functor_Parameter = Trim(Mid(strFunctor_ID_Plus_Parameters, p + 1))
0065 End If
0066 Else
0067 str_Functor_Parameter = "1"
0068 strFunctor_ID = strFunctor_ID_Plus_Parameters
0069 End If
0070 If Len(strFunctor_ID) <> 2 Then
0071 Debug.Print Now() & " - "; "Functor: ID invalid. Note="; Note_ID; "Functor ID ="; strFunctor_ID
0072 Else
0073 j = InStr(i, Note_Text_Local, strEnd_Comment & " ID=" & strFunctor_ID)
0074 If j = 0 Then
0075 Debug.Print Now() & " - "; "Functor: End-comment missing. Note="; Note_ID; " Functor_ID = " & strFunctor_ID & ", " & str_Functor_Parameter; ": Trying for ordinary End Tag"
0076 j = InStr(i, Note_Text_Local, strEnd_Comment)
0077 If j = 0 Then
0078 Debug.Print Now() & " - "; "Functor: End-comment missing. Note="; Note_ID; " Functor_ID = " & strFunctor_ID & ", " & str_Functor_Parameter; ": Ordinary End Tag also missing; giving up"
0079 Functor = "End-comment missing"
0080 Exit Function
0081 End If
0082 End If
0083 Dud_Functor = False
0084 Select Case strFunctor_ID
0085 Case "01"
0086 'Quarterly Report: Activity insert
0087 OK = Functor_01(Note_ID, Note_Title, Functor_Insert, "No")
0088 Case "02"
0089 'Development Log report - Completed Items by Date
0090 OK = Functor_02("Development_Log_List_Complete_Date", Functor_Insert)
0091 Case "03"
0092 'Development Log report - Outstanding Items by Priority
0093 OK = Functor_03("Development_Log_List_Outstanding_Own_Priority", Functor_Insert)
0094 OK_Local = Functor_03("Development_Log_List_Outstanding_Others_Priority", Functor_Insert_2)
0095 If OK_Local = "Yes" Then
0096 Functor_Insert = "|II||1|<b><u>Own Website</u>:</b> " & Functor_Insert & "|1|<b><u>Other Websites</u>:</b> " & Functor_Insert_2 & "|II|"
0097 End If
0098 Case "04"
0099 'Development Log report - Outstanding Items by Category
0100 OK = Functor_04("Development_Log_List_Outstanding_Own_Category", Functor_Insert)
0101 OK_Local = Functor_04("Development_Log_List_Outstanding_Others_Category", Functor_Insert_2)
0102 If OK_Local = "Yes" Then
0103 Functor_Insert = "|II||1|<b><u>Own Website</u>:</b> " & Functor_Insert & "|1|<b><u>Other Websites</u>:</b> " & Functor_Insert_2 & "|II|"
0104 End If
0105 Case "05"
0106 'Development Log report - Completed Items by Category
0107 OK = Functor_05("Development_Log_List_Complete_Own_Category", Functor_Insert)
0108 OK_Local = Functor_05("Development_Log_List_Complete_Others_Category", Functor_Insert_2)
0109 If OK_Local = "Yes" Then
0110 Functor_Insert = "|II||1|<b><u>Own Website</u>:</b> " & Functor_Insert & "|1|<b><u>Other Websites</u>:</b> " & Functor_Insert_2 & "|II|"
0111 End If
0112 Case "06"
0113 'Quarterly Report: Priority 1 Outstanding Developents by Category
0114 OK = Functor_06("Development_Log_List_Outstanding_Own_Category_Pri1", Functor_Insert)
0115 OK_Local = Functor_06("Development_Log_List_Outstanding_Others_Category_Pri1", Functor_Insert_2)
0116 If OK_Local = "Yes" Then
0117 Functor_Insert = "|II||1|<b><u>Own Website</u>:</b> " & Functor_Insert & "|1|<b><u>Other Websites</u>:</b> " & Functor_Insert_2 & "|II|"
0118 End If
0119 Case "07"
0120 'Insert Stats into Note 1247 (Website Generator Documentation - Web Links)
0121 OK = Functor_07(Note_ID, Note_Title, Functor_Insert)
0122 Case "08"
0123 'Insert Stats into Quarterly Reports
0124 OK = Functor_08(Note_ID, Note_Title, Functor_Insert)
0125 Case "09"
0126 'Insert Plans for Near Future into Quarterly Reports
0127 OK = Functor_09(Note_ID, Note_Title, Functor_Insert)
0128 Case "10"
0129 'Insert Plans for Near Future into Summary Quarterly Report
0130 OK = Functor_10(Note_ID, Note_Title, Functor_Insert)
0131 Case "11"
0132 'Web-Tools Quarterly Report: Completed Developments by Category
0133 'Find the quarter
0134 OK = Find_Report_Period(Note_Title, strYear, strQuarter)
0135 strQuery = "SELECT File_Suffix FROM Next_Reporting_Month;"
0136 Set rst = CurrentDb.OpenRecordset(strQuery)
0137 rst.MoveFirst
0138 strQuarter_Check = rst.Fields(0)
0139 Set rst = Nothing
0140 If Right(strQuarter_Check, 2) = strQuarter Then
0141 strQuery = "Development_Log_List_Complete_Own_Category_Recent"
0142 strQuery_2 = "Development_Log_List_Complete_Others_Category_Recent"
0143 Else
0144 strQuery = "Development_Log_List_Complete_Own_Category_Recent_Previous"
0145 strQuery_2 = "Development_Log_List_Complete_Others_Category_Recent_Previous"
0146 End If
0147 OK = Functor_11(strQuery, Functor_Insert)
0148 OK_Local = Functor_11(strQuery_2, Functor_Insert_2)
0149 If OK_Local = "Yes" Then
0150 Functor_Insert = "|II||1|<b><u>Own Website</u>:</b> " & Functor_Insert & "|1|<b><u>Other Websites</u>:</b> " & Functor_Insert_2 & "|II|"
0151 Else
0152 Debug.Print Now() & " - "; "Functor Failed. Note ="; Note_ID; "Functor ID = "; strFunctor_ID; " (Other Websites)"
0153 End If
0154 Case "12"
0155 'Quarterly Report: YTD Activity insert
0156 OK = Functor_01(Note_ID, Note_Title, Functor_Insert, "Yes")
0157 Case "13"
0158 'Use Form_Documentation_Links to list Buttons referenced in Documenter
0159 OK = Functor_13(Note_ID, Note_Title, Functor_Insert)
0160 Case "14"
0161 'Create an HTML table for the Blog
0162 OK = Functor_14(Note_ID, Note_Title, Functor_Insert)
0163 Case "15"
0164 'Create a Timeline
0165 OK = Functor_15(Note_ID, Note_Title, Functor_Insert)
0166 Case "16"
0167 'Create a Timeline
0168 OK = Functor_16(Note_ID, Note_Title, Functor_Insert)
0169 Case "17"
0170 'Create an audio file list
0171 OK = Functor_17(Note_ID, Note_Title, Functor_Insert, str_Functor_Parameter)
0172 Case "18"
0173 'Create the Aeon Lists list
0174 Functor_Insert = ""
0175 OK = Functor_18(Note_ID, Note_Title, Functor_Insert, 1) 'Aeon items read
0176 OK = Functor_18(Note_ID, Note_Title, Functor_Insert, 2) 'Aeon items un-read
0177 Case "19"
0178 'Create the Aeon List Note 1292 jump table
0179 Functor_Insert = ""
0180 OK = Functor_19(Note_ID, Note_Title, Functor_Insert) 'Aeon items read
0181 Case "21"
0182 'Insert table from Cross-Tab, or otherwise tabular, Query
0183 OK = Functor_21(str_Functor_Parameter, Functor_Insert, str_Functor_Parameter_2)
0184 Case "22"
0185 'Insert list from Select Query
0186 OK = Functor_22(str_Functor_Parameter, Functor_Insert, Note_ID, str_Functor_Parameter_2, str_Functor_Parameter_3)
0187 Case "23"
0188 'Insert value from Select Query
0189 If str_Functor_Parameter_2 = "" Then
0190 OK = Functor_23(Note_ID, str_Functor_Parameter, Functor_Insert)
0191 Else
0192 OK = Functor_23(Note_ID, str_Functor_Parameter, Functor_Insert, str_Functor_Parameter_2)
0193 End If
0194 Case "24"
0195 'Insert value from Select Query
0196 If str_Functor_Parameter_2 = "" Then
0197 str_Functor_Parameter_2 = "1"
0198 End If
0199 OK = Functor_24(Note_ID, str_Functor_Parameter, Functor_Insert, str_Functor_Parameter_2)
0200 Case Else
0201 Dud_Functor = True
0202 Debug.Print Now() & " - "; "Functor: ID unrecognised. Note ="; Note_ID; "Functor ID = "; strFunctor_ID
0203 End Select
0204 If OK <> "Yes" Then
0205 Dud_Functor = True
0206 Debug.Print Now() & " - "; "Functor Failed. Note="; Note_ID; "Functor ID = "; strFunctor_ID
0207 End If
0208 If Dud_Functor = False Then
0209 Functor = "Yes"
0210 'Replace old functor-stuff with new functor-stuff
0211 Note_Text_Local = Left(Note_Text_Local, n + 2) & Functor_Insert & Mid(Note_Text_Local, j)
0212 Else
0213 Note_Text_Local = Left(Note_Text_Local, n + 2) & Mid(Note_Text_Local, j) 'ADDED 12/08/2021
0214 End If
0215 End If
0216 End If
0217 'Find the next one ...
0218 i = InStr(i + 1, Note_Text_Local, strStart_Comment)
0219Loop
0220Note_Text = Note_Text_Local
0221End Function

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


Source Code of: Map_WebRefs
Procedure Type: Public Sub
Module: Testing
Lines of Code: 118
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Map_WebRefs()
0002Dim rsObject As Recordset
0003Dim strQuery As String
0004Dim iUpdates As Long
0005Dim iSub_Total As Long
0006Dim iTotal As Long
0007Dim Duration As Single
0008Dim RunStartTime As Date
0009Dim Message As String
0010If automatic_processing = "Yes" Then
0011Else
0012 Message = MsgBox("Map WebRefs: Re-create the WebRef_Maps Table?", vbYesNo)
0013 If Message = vbNo Then
0014 Exit Sub
0015 End If
0016End If
0017iTotal = 0
0018RunStartTime = Now()
0019'Delete Former Mappings
0020 strQuery = "DELETE WebRef_Maps.* FROM WebRef_Maps;"
0021DoCmd.RunSQL (strQuery)
0022'Translate Authors
0023iSub_Total = 0
0024 strQuery = "SELECT Authors.Author_ID, Authors.Author_Narrative FROM Authors WHERE (((Authors.Author_Narrative) Like ""*+W*""));"
0025Set rsObject = CurrentDb.OpenRecordset(strQuery)
0026If Not rsObject.EOF Then
0027 rsObject.MoveFirst
0028 Do Until rsObject.EOF
0029 iUpdates = Map_WebRefs_Mapper("Author", rsObject.Fields(0), 0, rsObject.Fields(1))
0030 iSub_Total = iSub_Total + iUpdates
0031 rsObject.MoveNext
0032 Loop
0033End If
0034Set rsObject = Nothing
0035iTotal = iTotal + iSub_Total
0036If automatic_processing <> "Yes" Then
0037 Debug.Print Now() & " - "; "Map_WebRefs: Total Author WebRefs = " & iSub_Total
0038End If
0039'Translate Notes
0040iSub_Total = 0
0041 strQuery = "SELECT Notes.ID, Notes.Item_Text, Notes.Note_Group FROM Notes WHERE (((Notes.Item_Text) Like ""*+W*""));"
0042Set rsObject = CurrentDb.OpenRecordset(strQuery)
0043If Not rsObject.EOF Then
0044 rsObject.MoveFirst
0045 Do Until rsObject.EOF
0046 iUpdates = Map_WebRefs_Mapper("Note", rsObject.Fields(0), 0, rsObject.Fields(1), rsObject.Fields(2))
0047 iSub_Total = iSub_Total + iUpdates
0048 rsObject.MoveNext
0049 Loop
0050End If
0051Set rsObject = Nothing
0052iTotal = iTotal + iSub_Total
0053If automatic_processing <> "Yes" Then
0054 Debug.Print Now() & " - "; "Map_WebRefs: Total Note WebRefs = " & iSub_Total
0055End If
0056'Translate Notes_Archive
0057iSub_Total = 0
0058 strQuery = "SELECT Notes_Archive.ID, Notes_Archive.[Timestamp], Notes_Archive.Item_Text, Notes_Archive.Note_Group FROM Notes_Archive WHERE (((Notes_Archive.Item_Text) Like ""*+W*""));"
0059Set rsObject = CurrentDb.OpenRecordset(strQuery)
0060If Not rsObject.EOF Then
0061 rsObject.MoveFirst
0062 Do Until rsObject.EOF
0063 iUpdates = Map_WebRefs_Mapper("Note_Archive", rsObject.Fields(0), rsObject.Fields(1), rsObject.Fields(2), rsObject.Fields(3))
0064 iSub_Total = iSub_Total + iUpdates
0065 rsObject.MoveNext
0066 Loop
0067End If
0068Set rsObject = Nothing
0069iTotal = iTotal + iSub_Total
0070If automatic_processing <> "Yes" Then
0071 Debug.Print Now() & " - "; "Map_WebRefs: Total Note_Archive WebRefs = " & iSub_Total
0072End If
0073'Translate Book Abstracts & Comments
0074iSub_Total = 0
0075 strQuery = "SELECT Books.ID1, Books.Comments, Books.Abstract FROM Books WHERE (((Books.Comments) Like ""*+W*"") OR ((Books.Abstract) Like ""*+W*""));"
0076Set rsObject = CurrentDb.OpenRecordset(strQuery)
0077If Not rsObject.EOF Then
0078 rsObject.MoveFirst
0079 Do Until rsObject.EOF
0080 iUpdates = Map_WebRefs_Mapper("Book", rsObject.Fields(0), 0, rsObject.Fields(1) & rsObject.Fields(2))
0081 iSub_Total = iSub_Total + iUpdates
0082 rsObject.MoveNext
0083 Loop
0084End If
0085Set rsObject = Nothing
0086iTotal = iTotal + iSub_Total
0087If automatic_processing <> "Yes" Then
0088 Debug.Print Now() & " - "; "Map_WebRefs: Total Book WebRefs = " & iSub_Total
0089End If
0090'Translate Paper Abstracts & Comments
0091iSub_Total = 0
0092 strQuery = "SELECT Papers.ID, Papers.Comments, Papers.Abstract FROM Papers WHERE (((Papers.Comments) Like ""*+W*"") OR ((Papers.Abstract) Like ""*+W*""));"
0093Set rsObject = CurrentDb.OpenRecordset(strQuery)
0094If Not rsObject.EOF Then
0095 rsObject.MoveFirst
0096 Do Until rsObject.EOF
0097 iUpdates = Map_WebRefs_Mapper("Paper", rsObject.Fields(0), 0, rsObject.Fields(1) & rsObject.Fields(2))
0098 iSub_Total = iSub_Total + iUpdates
0099 rsObject.MoveNext
0100 Loop
0101End If
0102Set rsObject = Nothing
0103iTotal = iTotal + iSub_Total
0104If automatic_processing <> "Yes" Then
0105 Debug.Print Now() & " - "; "Map_WebRefs: Total Paper WebRefs = " & iSub_Total
0106 Debug.Print Now() & " - "; "Map_WebRefs: Total WebRefs Mapped = " & iTotal
0107End If
0108If automatic_processing = "Yes" Then
0109Else
0110 Duration = Round((Now() - RunStartTime) * 24 * 60, 1)
0111 If Duration < 1 Then
0112 Duration = Round((Now() - RunStartTime) * 24 * 60 * 60)
0113 MsgBox "WebRefs Mapped in " & Duration & " seconds. " & iTotal & " records added.", vbOKOnly, "Map WebRefs"
0114 Else
0115 MsgBox "WebRefs Mapped in " & Duration & " minutes. " & iTotal & " records added.", vbOKOnly, "Map WebRefs"
0116 End If
0117End If
0118End Sub

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


Source Code of: Map_WebRefs_Mapper
Procedure Type: Public Function
Module: Testing
Lines of Code: 75
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Map_WebRefs_Mapper(Object_Type As String, Object_ID As Long, Object_Sub_ID As Long, Object_Text As String, Optional Security As String) As Integer
0002Dim iCount As Integer
0003Dim Find_Start As String
0004Dim Find_End As String
0005Dim rsWebRef_Maps As Recordset
0006Dim strQuery As String
0007Dim i As Long
0008Dim j As Long
0009Dim strWebRef As String
0010iCount = 0
0011Find_Start = "+W"
0012Find_End = "W+"
0013On Error Resume Next 'A bit of a fudge - to allow for duplicate key without too much of an overhead.
0014'Anything to do?
0015If Len(Object_Text) = 0 Then
0016 GoTo The_End
0017End If
0018If InStr(Object_Text, Find_Start) = 0 Then
0019 GoTo The_End
0020End If
0021'Ready for inserts
0022 strQuery = "SELECT * FROM WebRef_Maps WHERE Object_Type = """ & Object_Type & """ AND Object_ID = " & Object_ID & " AND Object_Sub_ID = " & Object_Sub_ID & ";"
0023Set rsWebRef_Maps = CurrentDb.OpenRecordset(strQuery)
0024i = InStr(Object_Text, Find_Start)
0025'Search and Add Mappings
0026Do While i > 0
0027 j = InStr(i, Object_Text, Find_End)
0028 If j > 0 Then
0029 strWebRef = Mid(Object_Text, i + 2, j - i - 2)
0030 If Len(strWebRef) > 5 Then
0031 'Dud ... ignore
0032 If automatic_processing <> "Yes" Then
0033 Debug.Print Now() & " - "; "Error: Map_WebRefs_Mapper: WebRef too long. "; " "; Object_Type; " "; Object_ID; " "; Object_Sub_ID; " "; Replace(Replace(Left(strWebRef, 20), Chr(13), " "), Chr$(10), "")
0034 End If
0035 j = i + 1
0036 Else
0037 If IsNumeric(strWebRef) Then
0038 rsWebRef_Maps.AddNew
0039 rsWebRef_Maps.Fields(0) = Object_Type
0040 rsWebRef_Maps.Fields(1) = Object_ID
0041 rsWebRef_Maps.Fields(2) = Object_Sub_ID
0042 rsWebRef_Maps.Fields(3) = strWebRef
0043 If IsMissing(Security) Then
0044 rsWebRef_Maps.Fields(4) = ""
0045 Else
0046 rsWebRef_Maps.Fields(4) = Security
0047 End If
0048 rsWebRef_Maps.Fields(5) = Now()
0049 rsWebRef_Maps.Update
0050 iCount = iCount + 1
0051 Else
0052 'Igore documentation dummies
0053 If (strWebRef & "" = "") Or (strWebRef = "nnn") Or (strWebRef = "mmm") Or (strWebRef = "nnnn") Or (strWebRef = "mmmm") Then
0054 Else
0055 If automatic_processing <> "Yes" Then
0056 Debug.Print Now() & " - "; "Error: Map_WebRefs_Mapper: WebRef not numeric. "; " "; Object_Type; " "; Object_ID; " "; Object_Sub_ID; " "; Left(strWebRef, 20)
0057 End If
0058 End If
0059 j = i + 1
0060 End If
0061 End If
0062 i = InStr(j, Object_Text, Find_Start)
0063 Else
0064 'Error
0065 If automatic_processing <> "Yes" Then
0066 Debug.Print Now() & " - "; "Error: Map_WebRefs_Mapper: W+ missing. "; " "; Object_Type; " "; Object_ID; " "; Object_Sub_ID; " "; Replace(Replace(Mid(Object_Text, i, 20), Chr(13), " "), Chr$(10), "")
0067 End If
0068 i = 0
0069 End If
0070Loop
0071The_End:
0072'Return Count
0073Map_WebRefs_Mapper = iCount
0074Set rsWebRef_Maps = Nothing
0075End Function

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


Source Code of: Monthly_Reporting
Procedure Type: Public Sub
Module: Monthly Reporting
Lines of Code: 30
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Monthly_Reporting()
0002Dim Start_Time
0003Dim i As Integer
0004Start_Time = Now()
0005If MsgBox("Have you set the Reporting Month?", vbYesNo) = vbYes Then
0006 DoCmd.OpenQuery "Year_Crosstab_List_Zap", acViewNormal, acEdit
0007 DoCmd.OpenQuery "Year_Crosstab_List_GEN", acViewNormal, acEdit
0008 DoCmd.OpenQuery "Year_Crosstab_List_Add", acViewNormal, acEdit
0009 DoCmd.OpenQuery "Year_Crosstab_Zap", acViewNormal, acEdit
0010 DoCmd.OpenQuery "Year_Crosstab_GEN", acViewNormal, acEdit
0011 DoCmd.OpenQuery "Year_Crosstab_Add", acViewNormal, acEdit
0012 'Generate Temp webpages
0013 automatic_processing = "Yes"
0014 Done_The_Jumps = False
0015 'Output the Notes
0016 Monthly_Report_Note863_Update
0017 Monthly_Report_Note980_Update
0018 For i = 1 To 3
0019 Monthly_Report_Note1005_Update (i)
0020 Next i
0021 Monthly_Report_Note1024_Output
0022 WebRefs_Checker_Pages_Gen
0023 MsgBox ("Monthly Reporting Completed OK in " & Round((Now() - Start_Time) * 24 * 60, 1) & " minutes.")
0024Else
0025 DoCmd.OpenTable ("Next_Reporting_Month")
0026 If MsgBox("Have you just changed the copyright month and want to run the update?", vbYesNo) = vbYes Then
0027 DoCmd.OpenQuery ("WebPage_DateChange")
0028 End If
0029End If
0030End Sub

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


Source Code of: Test_It
Procedure Type: Public Sub
Module: Testing
Lines of Code: 13

Line-No. / Ref.Code Line
0001Public Sub Test_It()
0002Dim start As Date
0003Dim Duration As Single
0004Dim rs As Recordset
0005Dim strQuery As String
0006Dim Note_Text As String
0007Dim Note_Text_Saved As String
0008Dim i As Integer
0009start = Now()
0010Debug.Print Now() & " - " & i & " Notes records updated"
0011Duration = Round((Now() - start) * 24 * 60 * 60, 2)
0012MsgBox "Test Complete in " & Duration & " seconds. ", vbOKOnly, "Test"
0013End Sub

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


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