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: 87
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 Start_Parsing_Time As Single
0016Dim No_Backup_Now
0017Dim No_Backup_Later
0018Dim Response
0019Dim SiteMapDirectory As String
0020Dim Directory_Timestamp_Local
0021'This is a recursive Sub - ie. it calls itself
0022Backup_Prune_Scurry = "OK"
0023DirectoryLevel = DirectoryLevel_In + 1
0024Directories_Logged = Directories_Logged + 1
0025Set db = CurrentDb
0026'Write out a record (to Full_Backup_Directory_Structure_Temp) for each sub-directory
0027 Set rst2 = db.OpenRecordset("SELECT Full_Backup_Directory_Structure_Temp.* FROM Full_Backup_Directory_Structure_Temp;")
0028rst2.AddNew
0029rst2.Fields(0) = DirectoryName
0030rst2.Fields(1) = DirectoryLevel
0031rst2.Fields(2) = Now()
0032rst2.Fields(3) = Directory_Timestamp
0033rst2.Update
0034Set rst2 = Nothing
0035Set fso = CreateObject("Scripting.FileSystemObject")
0036If (Now() - Time_Start_Old) * 24 > 0.25 Then
0037 Compact_Repair (Backup_Database)
0038 Time_Start_Old = Now()
0039 Files_Logged = 0
0040Else
0041 If Directory_Only = False Then
0042 If Files_Logged > 200000 Then
0043 Files_Logged = 0
0044 Compact_Repair (Backup_Database)
0045 End If
0046 End If
0047End If
0048Set MainFolder = fso.GetFolder(DirectoryName)
0049If Directory_Only = False Then
0050 Set FileCollection = MainFolder.Files
0051 Set rst2 = db.OpenRecordset("SELECT Full_Backup_Site_Map_Temp.* FROM Full_Backup_Site_Map_Temp;")
0052 'Main Folders
0053 On Error Resume Next
0054 For Each File In FileCollection
0055 File_Wanted = "Yes"
0056 File_Name = File.Name
0057 File_Timestamp = File.DateLastModified
0058 Start_Parsing_Time = Now()
0059 'Log file stats
0060 SiteMapDirectory = DirectoryName
0061 rst2.AddNew
0062 rst2.Fields(0) = SiteMapDirectory
0063 rst2.Fields(1) = File_Name
0064 rst2.Fields(2) = Now()
0065 rst2.Fields(3) = File.Size
0066 rst2.Fields(4) = SiteMapDirectory & File_Name
0067 rst2.Fields(5) = File_Timestamp
0068 rst2.Update
0069 Files_Processed = Files_Processed + 1
0070 Files_Logged = Files_Logged + 1
0071 Next File
0072 Set rst2 = Nothing
0073End If
0074Recursion:
0075Set FileCollection = MainFolder.SubFolders
0076For Each File In FileCollection
0077 File_Name = File.Name
0078 Directory_Timestamp_Local = File.DateLastModified
0079 Directory_Out = DirectoryName & File_Name & "\"
0080 'Recursion ...
0081 OK = Backup_Prune_Scurry(Directory_Out, Directory_Timestamp_Local, DirectoryLevel, Backup_Database, Directory_Only)
0082Next File
0083Set rst2 = Nothing
0084Set rst = Nothing
0085Set MainFolder = Nothing
0086Set FileCollection = Nothing
0087End 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

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

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
0008start = Now()
0009Dim i As Integer
0010 strQuery = "SELECT Notes.Note_Group, Notes.Item_Title, Notes.Item_Text FROM Notes WHERE (((Notes.Note_Group)=1) AND ((Notes.Item_Title) Not Like ""*Thesis*"")) ORDER BY Notes.Note_Group, Notes.Item_Title;"
0011Set rs = CurrentDb.OpenRecordset(strQuery)
0012rs.MoveFirst
0013i = 0
0014Do Until rs.EOF
0015 Note_Text = rs.Fields(2)
0016 Note_Text_Saved = Note_Text
0017 Note_Text = Replace(Note_Text, "FUNCTOR_ID=22, 6", "FUNCTOR_ID=22, 8")
0018 Note_Text = Replace(Note_Text, "FUNCTOR_ID=22, 7", "FUNCTOR_ID=22, 9")
0019 If Note_Text_Saved <> Note_Text Then
0020 rs.Edit
0021 rs.Fields(2) = Note_Text
0022 rs.Update
0023 i = i + 1
0024 End If
0025 rs.MoveNext
0026Loop
0027Debug.Print Now() & " - " & i & " Notes records updated"
0028Duration = Round((Now() - start) * 24 * 60 * 60, 2)
0029MsgBox "Test Complete in " & Duration & " seconds. ", vbOKOnly, "Test"
0030End Sub

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



© Theo Todman, June 2007 - August 2021. 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