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

Line-No. / Ref.Code Line
0001Public Sub Test_It()
0002Dim start As Date
0003Dim Duration As Single
0004Dim strQuery As String
0005Dim strTable As String
0006 strQuery = "Query7"
0007start = Now()
0008'OK = Cross_Tab_Table_GEN(strQuery, strTable)
0009 OK = Number_Format(1234567)
0010Duration = Round((Now() - start) * 24 * 60 * 60, 2)
0011MsgBox "Test Complete in " & Duration & " seconds. ", vbOKOnly, "Test"
0012End Sub

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



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