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: 188
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 Note_Text_Local As String
0008Dim strStart_Comment As String
0009Dim strEnd_Comment As String
0010Dim strFunctor_ID As String
0011Dim Dud_Functor As Boolean
0012Dim Functor_Insert As String
0013Dim Functor_Insert_2 As String
0014Dim OK_Local As String
0015Dim strYear As String
0016Dim strQuarter As String
0017Dim strQuarter_Check As String
0018Dim strQuery As String
0019Dim strQuery_2 As String
0020Dim rst As Recordset
0021Dim str_Functor_Parameter As String
0022strStart_Comment = "<!-- FUNCTOR_ID="
0023m = Len(strStart_Comment)
0024strEnd_Comment = "<!-- FUNCTOR_END"
0025Note_Text_Local = Note_Text
0026Functor = "No"
0027'Find the comment with instructions!
0028i = InStr(Note_Text_Local, strStart_Comment)
0029If i = 0 Then
0030 Functor = "Nothing to Do"
0031 Exit Function
0032End If
0033Do While i > 0
0034 'Process the Functor ... find the ID
0035 n = InStr(i, Note_Text_Local, "-->")
0036 If n = 0 Then
0037 'End tag not found
0038 Debug.Print Now() & " - "; "Functor: End-tag fir ID missing. Note="; Note_ID
0039 Else
0040 strFunctor_ID = Trim(Mid(Note_Text_Local, i + m, n - i - m))
0041 'Check for Parameter
0042 p = InStr(strFunctor_ID, ",")
0043 If p > 0 Then
0044 str_Functor_Parameter = Trim(Mid(strFunctor_ID, p + 1))
0045 strFunctor_ID = Left(strFunctor_ID, p - 1)
0046 Else
0047 str_Functor_Parameter = "1"
0048 End If
0049 If Len(strFunctor_ID) <> 2 Then
0050 Debug.Print Now() & " - "; "Functor: ID invalid. Note="; Note_ID; "Functor ID ="; strFunctor_ID
0051 Else
0052 j = InStr(i, Note_Text_Local, strEnd_Comment & " ID=" & strFunctor_ID)
0053 If j = 0 Then
0054 Debug.Print Now() & " - "; "Functor: End-comment missing. Note="; Note_ID; " Functor_ID = " & strFunctor_ID & ", " & str_Functor_Parameter; ": Trying for ordinary End Tag"
0055 j = InStr(i, Note_Text_Local, strEnd_Comment)
0056 If j = 0 Then
0057 Debug.Print Now() & " - "; "Functor: End-comment missing. Note="; Note_ID; " Functor_ID = " & strFunctor_ID & ", " & str_Functor_Parameter; ": Ordinary End Tag also missing; giving up"
0058 Functor = "End-comment missing"
0059 Exit Function
0060 End If
0061 End If
0062 Dud_Functor = False
0063 Select Case strFunctor_ID
0064 Case "01"
0065 'Quarterly Report: Activity insert
0066 OK = Functor_01(Note_ID, Note_Title, Functor_Insert, "No")
0067 Case "02"
0068 'Development Log report - Completed Items by Date
0069 OK = Functor_02("Development_Log_List_Complete_Date", Functor_Insert)
0070 Case "03"
0071 'Development Log report - Outstanding Items by Priority
0072 OK = Functor_03("Development_Log_List_Outstanding_Own_Priority", Functor_Insert)
0073 OK_Local = Functor_03("Development_Log_List_Outstanding_Others_Priority", Functor_Insert_2)
0074 If OK_Local = "Yes" Then
0075 Functor_Insert = "|II||1|<b><u>Own Website</u>:</b> " & Functor_Insert & "|1|<b><u>Other Websites</u>:</b> " & Functor_Insert_2 & "|II|"
0076 End If
0077 Case "04"
0078 'Development Log report - Outstanding Items by Category
0079 OK = Functor_04("Development_Log_List_Outstanding_Own_Category", Functor_Insert)
0080 OK_Local = Functor_04("Development_Log_List_Outstanding_Others_Category", Functor_Insert_2)
0081 If OK_Local = "Yes" Then
0082 Functor_Insert = "|II||1|<b><u>Own Website</u>:</b> " & Functor_Insert & "|1|<b><u>Other Websites</u>:</b> " & Functor_Insert_2 & "|II|"
0083 End If
0084 Case "05"
0085 'Development Log report - Completed Items by Category
0086 OK = Functor_05("Development_Log_List_Complete_Own_Category", Functor_Insert)
0087 OK_Local = Functor_05("Development_Log_List_Complete_Others_Category", Functor_Insert_2)
0088 If OK_Local = "Yes" Then
0089 Functor_Insert = "|II||1|<b><u>Own Website</u>:</b> " & Functor_Insert & "|1|<b><u>Other Websites</u>:</b> " & Functor_Insert_2 & "|II|"
0090 End If
0091 Case "06"
0092 'Quarterly Report: Priority 1 Outstanding Developents by Category
0093 OK = Functor_06("Development_Log_List_Outstanding_Own_Category_Pri1", Functor_Insert)
0094 OK_Local = Functor_06("Development_Log_List_Outstanding_Others_Category_Pri1", 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 "07"
0099 'Insert Stats into Note 1247 (Website Generator Documentation - Web Links)
0100 OK = Functor_07(Note_ID, Note_Title, Functor_Insert)
0101 Case "08"
0102 'Insert Stats into Quarterly Reports
0103 OK = Functor_08(Note_ID, Note_Title, Functor_Insert)
0104 Case "09"
0105 'Insert Plans for Near Future into Quarterly Reports
0106 OK = Functor_09(Note_ID, Note_Title, Functor_Insert)
0107 Case "10"
0108 'Insert Plans for Near Future into Summary Quarterly Report
0109 OK = Functor_10(Note_ID, Note_Title, Functor_Insert)
0110 Case "11"
0111 'Web-Tools Quarterly Report: Completed Developments by Category
0112 'Find the quarter
0113 OK = Find_Report_Period(Note_Title, strYear, strQuarter)
0114 strQuery = "SELECT File_Suffix FROM Next_Reporting_Month;"
0115 Set rst = CurrentDb.OpenRecordset(strQuery)
0116 rst.MoveFirst
0117 strQuarter_Check = rst.Fields(0)
0118 Set rst = Nothing
0119 If Right(strQuarter_Check, 2) = strQuarter Then
0120 strQuery = "Development_Log_List_Complete_Own_Category_Recent"
0121 strQuery_2 = "Development_Log_List_Complete_Others_Category_Recent"
0122 Else
0123 strQuery = "Development_Log_List_Complete_Own_Category_Recent_Previous"
0124 strQuery_2 = "Development_Log_List_Complete_Others_Category_Recent_Previous"
0125 End If
0126 OK = Functor_11(strQuery, Functor_Insert)
0127 OK_Local = Functor_11(strQuery_2, Functor_Insert_2)
0128 If OK_Local = "Yes" Then
0129 Functor_Insert = "|II||1|<b><u>Own Website</u>:</b> " & Functor_Insert & "|1|<b><u>Other Websites</u>:</b> " & Functor_Insert_2 & "|II|"
0130 Else
0131 Debug.Print Now() & " - "; "Functor Failed. Note="; Note_ID; "Functor ID = "; strFunctor_ID; " (Other Websites)"
0132 End If
0133 Case "12"
0134 'Quarterly Report: YTD Activity insert
0135 OK = Functor_01(Note_ID, Note_Title, Functor_Insert, "Yes")
0136 Case "13"
0137 'Use Form_Documentation_Links to list Buttons referenced in Documenter
0138 OK = Functor_13(Note_ID, Note_Title, Functor_Insert)
0139 Case "14"
0140 'Create an HTML table for the Blog
0141 OK = Functor_14(Note_ID, Note_Title, Functor_Insert)
0142 Case "15"
0143 'Create a Timeline
0144 OK = Functor_15(Note_ID, Note_Title, Functor_Insert)
0145 Case "16"
0146 'Create a Timeline
0147 OK = Functor_16(Note_ID, Note_Title, Functor_Insert)
0148 Case "17"
0149 'Create an audio file list
0150 OK = Functor_17(Note_ID, Note_Title, Functor_Insert, str_Functor_Parameter)
0151 Case "18"
0152 'Create the Aeon Lists list
0153 Functor_Insert = ""
0154 OK = Functor_18(Note_ID, Note_Title, Functor_Insert, 1) 'Aeon items read
0155 OK = Functor_18(Note_ID, Note_Title, Functor_Insert, 2) 'Aeon items un-read
0156 Case "19"
0157 'Create the Aeon List Note 1292 jump table
0158 Functor_Insert = ""
0159 OK = Functor_19(Note_ID, Note_Title, Functor_Insert) 'Aeon items read
0160 Case "21"
0161 'Insert table from Cross-Tab, or otherwise tabular, Query
0162 OK = Functor_21(str_Functor_Parameter, Functor_Insert)
0163 Case "22"
0164 'Insert list from Select Query
0165 OK = Functor_22(str_Functor_Parameter, Functor_Insert)
0166 Case "23"
0167 'Insert value from Select Query
0168 OK = Functor_23(Note_ID, str_Functor_Parameter, Functor_Insert)
0169 Case Else
0170 Dud_Functor = True
0171 Debug.Print Now() & " - "; "Functor: ID unrecognised. Note ="; Note_ID; "Functor ID = "; strFunctor_ID
0172 End Select
0173 If OK <> "Yes" Then
0174 Dud_Functor = True
0175 Debug.Print Now() & " - "; "Functor Failed. Note="; Note_ID; "Functor ID = "; strFunctor_ID
0176 End If
0177 If Dud_Functor = False Then
0178 Functor = "Yes"
0179 'Replace old functor-stuff with new functor-stuff
0180 Note_Text_Local = Left(Note_Text_Local, n + 3) & Functor_Insert & Mid(Note_Text_Local, j)
0181 End If
0182 End If
0183 End If
0184 'Find the next one ...
0185 i = InStr(i + 1, Note_Text_Local, strStart_Comment)
0186Loop
0187Note_Text = Note_Text_Local
0188End 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: 115
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'Translate Authors
0020iSub_Total = 0
0021 strQuery = "SELECT Authors.Author_ID, Authors.Author_Narrative FROM Authors WHERE (((Authors.Author_Narrative) Like ""*+W*""));"
0022Set rsObject = CurrentDb.OpenRecordset(strQuery)
0023If Not rsObject.EOF Then
0024 rsObject.MoveFirst
0025 Do Until rsObject.EOF
0026 iUpdates = Map_WebRefs_Mapper("Author", rsObject.Fields(0), 0, rsObject.Fields(1))
0027 iSub_Total = iSub_Total + iUpdates
0028 rsObject.MoveNext
0029 Loop
0030End If
0031Set rsObject = Nothing
0032iTotal = iTotal + iSub_Total
0033If automatic_processing <> "Yes" Then
0034 Debug.Print Now() & " - "; "Map_WebRefs: Total Author WebRefs = " & iSub_Total
0035End If
0036'Translate Notes
0037iSub_Total = 0
0038 strQuery = "SELECT Notes.ID, Notes.Item_Text, Notes.Note_Group FROM Notes WHERE (((Notes.Item_Text) Like ""*+W*""));"
0039Set rsObject = CurrentDb.OpenRecordset(strQuery)
0040If Not rsObject.EOF Then
0041 rsObject.MoveFirst
0042 Do Until rsObject.EOF
0043 iUpdates = Map_WebRefs_Mapper("Note", rsObject.Fields(0), 0, rsObject.Fields(1), rsObject.Fields(2))
0044 iSub_Total = iSub_Total + iUpdates
0045 rsObject.MoveNext
0046 Loop
0047End If
0048Set rsObject = Nothing
0049iTotal = iTotal + iSub_Total
0050If automatic_processing <> "Yes" Then
0051 Debug.Print Now() & " - "; "Map_WebRefs: Total Note WebRefs = " & iSub_Total
0052End If
0053'Translate Notes_Archive
0054iSub_Total = 0
0055 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*""));"
0056Set rsObject = CurrentDb.OpenRecordset(strQuery)
0057If Not rsObject.EOF Then
0058 rsObject.MoveFirst
0059 Do Until rsObject.EOF
0060 iUpdates = Map_WebRefs_Mapper("Note_Archive", rsObject.Fields(0), rsObject.Fields(1), rsObject.Fields(2), rsObject.Fields(3))
0061 iSub_Total = iSub_Total + iUpdates
0062 rsObject.MoveNext
0063 Loop
0064End If
0065Set rsObject = Nothing
0066iTotal = iTotal + iSub_Total
0067If automatic_processing <> "Yes" Then
0068 Debug.Print Now() & " - "; "Map_WebRefs: Total Note_Archive WebRefs = " & iSub_Total
0069End If
0070'Translate Book Abstracts & Comments
0071iSub_Total = 0
0072 strQuery = "SELECT Books.ID1, Books.Comments, Books.Abstract FROM Books WHERE (((Books.Comments) Like ""*+W*"") OR ((Books.Abstract) Like ""*+W*""));"
0073Set rsObject = CurrentDb.OpenRecordset(strQuery)
0074If Not rsObject.EOF Then
0075 rsObject.MoveFirst
0076 Do Until rsObject.EOF
0077 iUpdates = Map_WebRefs_Mapper("Book", rsObject.Fields(0), 0, rsObject.Fields(1) & rsObject.Fields(2))
0078 iSub_Total = iSub_Total + iUpdates
0079 rsObject.MoveNext
0080 Loop
0081End If
0082Set rsObject = Nothing
0083iTotal = iTotal + iSub_Total
0084If automatic_processing <> "Yes" Then
0085 Debug.Print Now() & " - "; "Map_WebRefs: Total Book WebRefs = " & iSub_Total
0086End If
0087'Translate Paper Abstracts & Comments
0088iSub_Total = 0
0089 strQuery = "SELECT Papers.ID, Papers.Comments, Papers.Abstract FROM Papers WHERE (((Papers.Comments) Like ""*+W*"") OR ((Papers.Abstract) Like ""*+W*""));"
0090Set rsObject = CurrentDb.OpenRecordset(strQuery)
0091If Not rsObject.EOF Then
0092 rsObject.MoveFirst
0093 Do Until rsObject.EOF
0094 iUpdates = Map_WebRefs_Mapper("Paper", rsObject.Fields(0), 0, rsObject.Fields(1) & rsObject.Fields(2))
0095 iSub_Total = iSub_Total + iUpdates
0096 rsObject.MoveNext
0097 Loop
0098End If
0099Set rsObject = Nothing
0100iTotal = iTotal + iSub_Total
0101If automatic_processing <> "Yes" Then
0102 Debug.Print Now() & " - "; "Map_WebRefs: Total Paper WebRefs = " & iSub_Total
0103 Debug.Print Now() & " - "; "Map_WebRefs: Total WebRefs Mapped = " & iTotal
0104End If
0105If automatic_processing = "Yes" Then
0106Else
0107 Duration = Round((Now() - RunStartTime) * 24 * 60, 1)
0108 If Duration < 1 Then
0109 Duration = Round((Now() - RunStartTime) * 24 * 60 * 60)
0110 MsgBox "WebRefs Mapped in " & Duration & " seconds. " & iTotal & " records added.", vbOKOnly, "Map WebRefs"
0111 Else
0112 MsgBox "WebRefs Mapped in " & Duration & " minutes. " & iTotal & " records added.", vbOKOnly, "Map WebRefs"
0113 End If
0114End If
0115End 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: 78
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'Delete Former Mappings
0022 strQuery = "DELETE * FROM WebRef_Maps WHERE Object_Type = """ & Object_Type & """ AND Object_ID = " & Object_ID & " AND Object_Sub_ID = " & Object_Sub_ID & ";"
0023DoCmd.RunSQL (strQuery)
0024'Ready for inserts
0025 strQuery = "SELECT * FROM WebRef_Maps WHERE Object_Type = """ & Object_Type & """ AND Object_ID = " & Object_ID & " AND Object_Sub_ID = " & Object_Sub_ID & ";"
0026Set rsWebRef_Maps = CurrentDb.OpenRecordset(strQuery)
0027i = InStr(Object_Text, Find_Start)
0028'Search and Add Mappings
0029Do While i > 0
0030 j = InStr(i, Object_Text, Find_End)
0031 If j > 0 Then
0032 strWebRef = Mid(Object_Text, i + 2, j - i - 2)
0033 If Len(strWebRef) > 5 Then
0034 'Dud ... ignore
0035 If automatic_processing <> "Yes" Then
0036 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), "")
0037 End If
0038 j = i + 1
0039 Else
0040 If IsNumeric(strWebRef) Then
0041 rsWebRef_Maps.AddNew
0042 rsWebRef_Maps.Fields(0) = Object_Type
0043 rsWebRef_Maps.Fields(1) = Object_ID
0044 rsWebRef_Maps.Fields(2) = Object_Sub_ID
0045 rsWebRef_Maps.Fields(3) = strWebRef
0046 If IsMissing(Security) Then
0047 rsWebRef_Maps.Fields(4) = ""
0048 Else
0049 rsWebRef_Maps.Fields(4) = Security
0050 End If
0051 rsWebRef_Maps.Fields(5) = Now()
0052 rsWebRef_Maps.Update
0053 iCount = iCount + 1
0054 Else
0055 'Igore documentation dummies
0056 If (strWebRef & "" = "") Or (strWebRef = "nnn") Or (strWebRef = "mmm") Or (strWebRef = "nnnn") Or (strWebRef = "mmmm") Then
0057 Else
0058 If automatic_processing <> "Yes" Then
0059 Debug.Print Now() & " - "; "Error: Map_WebRefs_Mapper: WebRef not numeric. "; " "; Object_Type; " "; Object_ID; " "; Object_Sub_ID; " "; Left(strWebRef, 20)
0060 End If
0061 End If
0062 j = i + 1
0063 End If
0064 End If
0065 i = InStr(j, Object_Text, Find_Start)
0066 Else
0067 'Error
0068 If automatic_processing <> "Yes" Then
0069 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), "")
0070 End If
0071 i = 0
0072 End If
0073Loop
0074The_End:
0075'Return Count
0076Map_WebRefs_Mapper = iCount
0077Set rsWebRef_Maps = Nothing
0078End 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_Update
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: 15

Line-No. / Ref.Code Line
0001Public Sub Test_It()
0002Dim start As Date
0003Dim Duration As Single
0004Dim Cognate_Array(10) As Variant
0005Dim strWord As String
0006start = Now()
0007'Cognate_Array = Array("Implant", "Transplant", "Supplants")
0008Cognate_Array(1) = "Implant"
0009Cognate_Array(2) = "Transplant"
0010Cognate_Array(3) = "Supplants"
0011strWord = "This title contains Translants"
0012 OK = Spot_Invalid_Cognates(strWord, Cognate_Array)
0013Duration = Round((Now() - start) * 24 * 60 * 60, 2)
0014MsgBox "Test Complete in " & Duration & " seconds. ", vbOKOnly, "Test"
0015End Sub

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



© Theo Todman, June 2007 - Dec 2020. 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