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 39 (4 items)

cmdAuthorNarrUpdt_ClickcmdSearchAuthorNarrs_ClickBackup_ScurryBackup_Ctrl

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

Go to top of page



Source Code of: Backup_Ctrl
Procedure Type: Public Sub
Module: Backups
Lines of Code: 229
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Backup_Ctrl()
0002Dim fs As Object
0003Dim OK As String
0004Dim Start_Time As Date
0005Dim rst As Recordset
0006Dim rst2 As Recordset
0007Dim db As Database
0008Dim Run_Duration As Single
0009Dim Run_Duration_Text As String
0010Dim strQuery As String
0011Dim i As Integer
0012Dim j As Integer
0013Dim strMsg As String
0014Dim Backup_Depth As Integer
0015Dim strSubDirectory As String
0016Dim RecordsPrior As Long
0017Dim RecordsPost As Long
0018Dim Check_Directory As String
0019Dim Backup_Inconsistent_Msg As String
0020Dim Backup_Last_Run_Time As Single
0021 Backup_Errors = 0
0022Backup_Errors_Full = 0
0023Set db = CurrentDb
0024Start_Time = Now()
0025Files_Processed = 0
0026Backup_Errors_Stop = False
0027Backup_Files_Backed_Up = 0
0028Backup_Copy_Time = 0
0029 DoCmd.RunSQL ("DELETE Backup_Directory_Structure_Temp.* FROM Backup_Directory_Structure_Temp;")
0030 DoCmd.RunSQL ("DELETE Backup_Site_Map_Temp.* FROM Backup_Site_Map_Temp;")
0031 Set rst2 = db.OpenRecordset("SELECT Backup_Control.* FROM Backup_Control;")
0032If Not rst2.EOF Then
0033 rst2.MoveFirst
0034 Backup_Last_Run_Date = rst2.Fields(0).Value
0035 Backup_Changes_Since_Last_Run_Only = rst2.Fields(1).Value
0036 Backup_Last_Run_Time = rst2.Fields(3).Value
0037 Backup_Source_Root_Directory = rst2.Fields(5).Value
0038 Backup_Root_Directory = rst2.Fields(6).Value
0039 Backup_Index_Only = rst2.Fields(7).Value
0040 Backup_Mb_Check = rst2.Fields(8).Value
0041 Backup_Database = rst2.Fields(9).Value
0042 Backup_Website = rst2.Fields(10).Value
0043 Backup_Website_Root_Directory = rst2.Fields(11).Value
0044Else
0045 MsgBox ("Backup_Control table missing: process terminated. ")
0046 End
0047End If
0048Set rst2 = Nothing
0049'Check for (and supply if necessary) trailing "\"s
0050If Right(Backup_Source_Root_Directory, 1) <> "\" Then
0051 Backup_Source_Root_Directory = Backup_Source_Root_Directory & "\"
0052End If
0053If Right(Backup_Root_Directory, 1) <> "\" Then
0054 Backup_Root_Directory = Backup_Root_Directory & "\"
0055End If
0056Backup_Access_Root_Directory = Backup_Source_Root_Directory
0057Backup_Root_Directory = Backup_Root_Directory & "Backup - " & Right(Year(Now()) + 100, 2) & Right(Month(Now()) + 100, 2) & Right(Day(Now()) + 100, 2) & "\"
0058Check_Directory = Backup_Source_Root_Directory
0059Backup_Inconsistent_Msg = ""
0060If Left(Backup_Source_Root_Directory, 1) = Left(Backup_Root_Directory, 1) Then
0061 Backup_Inconsistent_Msg = "WARNING: Drives must differ. "
0062End If
0063If Left(Backup_Source_Root_Directory, 1) <> "C" Then
0064 Backup_Inconsistent_Msg = Backup_Inconsistent_Msg & "WARNING: Backup must be from C:drive. "
0065End If
0066 Set rst = db.OpenRecordset("SELECT Count(Backup_Site_Map.FIle_Name) AS CountOfFIle_Name FROM Backup_Site_Map WHERE (((Backup_Site_Map.Directory) Like ""*" & Check_Directory & "*""));")
0067rst.MoveFirst
0068RecordsPrior = rst.Fields(0)
0069Set rst = Nothing
0070strMsg = "Backup: Parameters are:- " & Chr$(10)
0071strMsg = strMsg & Chr$(10) & "Backup_Last_Run_Date = " & Backup_Last_Run_Date
0072strMsg = strMsg & Chr$(10) & "Backup_Last_Run_Time = " & Round(Backup_Last_Run_Time, 1) & " hours"
0073strMsg = strMsg & Chr$(10) & "Backup_Changes_Since_Last_Run_Only = " & Backup_Changes_Since_Last_Run_Only
0074strMsg = strMsg & Chr$(10) & "Backup_Source_Root_Directory = " & Backup_Source_Root_Directory
0075strMsg = strMsg & Chr$(10) & "Backup_Root_Directory = " & Backup_Root_Directory
0076strMsg = strMsg & Chr$(10) & "Backup_Access_Root_Directory = " & Backup_Access_Root_Directory
0077strMsg = strMsg & Chr$(10) & "Backup_Index_Only = " & Backup_Index_Only
0078If Backup_Index_Only = "Yes" Then
0079 strMsg = strMsg & ". WARNING: No files will be backed-up or restored."
0080End If
0081strMsg = strMsg & Chr$(10) & "Backup_Mb_Check = " & Backup_Mb_Check
0082strMsg = strMsg & Chr$(10) & "Backup_Database = " & Backup_Database
0083strMsg = strMsg & Chr$(10) & "Backup_Website_Root_Directory = " & Backup_Website_Root_Directory
0084If Backup_Website = True Then
0085 strMsg = strMsg & Chr$(10) & "Backup_Website = True"
0086Else
0087 strMsg = strMsg & Chr$(10) & "Backup_Website = False"
0088End If
0089strMsg = strMsg & Chr$(10) & "RecordsPrior = " & RecordsPrior
0090If Backup_Inconsistent_Msg <> "" Then
0091 strMsg = strMsg & Chr$(10) & Backup_Inconsistent_Msg
0092End If
0093strMsg = strMsg & Chr$(10) & Chr$(10) & "Proceed?"
0094If MsgBox(strMsg, vbYesNo) = vbNo Then
0095 End
0096Else
0097 DoCmd.Close acTable, "Backup_Control"
0098 DoCmd.Close acTable, "Backup_Directory_Structure"
0099 DoCmd.Close acTable, "Backup_Site_Map"
0100End If
0101MsgBox ("Off we go ... this MsgBox allows the tables to close!")
0102Debug.Print Now() & " - Backup_Ctrl: Backup started"
0103If Backup_Index_Only = "No" Then
0104 On Error Resume Next
0105 Set fs = CreateObject("Scripting.FileSystemObject")
0106 fs.CreateFolder (Left(Backup_Root_Directory, Len(Backup_Root_Directory) - 1))
0107 'Create Root Subdirectories
0108 i = InStr(Backup_Source_Root_Directory, "\")
0109 j = InStr(i + 1, Backup_Source_Root_Directory, "\")
0110 strSubDirectory = ""
0111 Do Until j = 0 Or i = 0
0112 strSubDirectory = strSubDirectory & Mid(Backup_Source_Root_Directory, i + 1, j - i)
0113 fs.CreateFolder (Backup_Root_Directory & strSubDirectory)
0114 i = j
0115 j = InStr(i + 1, Backup_Source_Root_Directory, "\")
0116 Loop
0117End If
0118i = 1
0119Backup_Depth = 0
0120'Find depth of Backup_Source_Root_Directory
0121i = 1
0122Do While i < Len(Backup_Source_Root_Directory) + 1
0123 If Mid(Backup_Source_Root_Directory, i, 1) = "\" Then
0124 Backup_Depth = Backup_Depth + 1
0125 End If
0126 i = i + 1
0127Loop
0128If Backup_Depth > 1 Then
0129 Backup_Depth = Backup_Depth - 2
0130End If
0131 strQuery = "SELECT Backup_Directory_Structure.* FROM Backup_Directory_Structure WHERE Backup_Directory_Structure.Directory = """ & Backup_Access_Root_Directory & """;"
0132Set rst2 = db.OpenRecordset(strQuery)
0133If rst2.EOF Then
0134 'Insert a record for the root directory if one doesn't exist
0135 rst2.AddNew
0136 i = InStr(Backup_Access_Root_Directory, "\")
0137 j = InStr(i, Backup_Access_Root_Directory, "\")
0138 Do Until j = Len(Backup_Access_Root_Directory)
0139 i = j
0140 j = InStr(i + 1, Backup_Access_Root_Directory, "\")
0141 Loop
0142 rst2.Fields(0) = Backup_Access_Root_Directory
0143 rst2.Fields(1) = Mid(Backup_Access_Root_Directory, i + 1, j - i - 1)
0144 rst2.Fields(2) = Backup_Depth
0145 rst2.Fields(3) = Now()
0146 rst2.Fields(4) = "No"
0147 rst2.Fields(5) = "No"
0148 rst2.Update
0149End If
0150Set rst2 = Nothing
0151Debug.Print Now() & " - Backup Scurry started"
0152Debug.Print Now() & " - Backup_Ctrl: entering Backup_Scurry"
0153 OK = Backup_Scurry(Backup_Source_Root_Directory, Backup_Depth)
0154'To get round the "Insufficient memory or disk space, you won't be able to undo; continue?" problem in the following update queries:-
0155'a) Set the query property UseTransaction to "No" (this still produces the message, but speeds things up)
0156'b) Set warnings off, as below
0157Debug.Print Now() & " - Backup_Ctrl: returned from Backup_Scurry"
0158DoCmd.SetWarnings (False)
0159'Update & Tidy Up any no-longer-existent items in Directory_Structure, ...
0160If Backup_Changes_Since_Last_Run_Only = "No" Then
0161 'Only delete if it's not a "changes only" run (any deletions will be resolved next time there's a full run)
0162 DoCmd.RunSQL ("DELETE Backup_Directory_Structure_Zapper.* FROM Backup_Directory_Structure_Zapper;")
0163 DoCmd.OpenQuery ("Backup_Directory_Structure_Zapper_GEN")
0164 DoCmd.OpenQuery ("Backup_Directory_Structure_Prune")
0165End If
0166 DoCmd.OpenQuery ("Backup_Directory_Structure_Add")
0167 DoCmd.OpenQuery ("Backup_Directory_Structure_Updt")
0168Debug.Print Now() & " - Backup_Ctrl: Directory Structure changes complete"
0169 DoCmd.RunSQL ("DELETE Backup_Directory_Structure_Temp.* FROM Backup_Directory_Structure_Temp;")
0170 DoCmd.RunSQL ("INSERT INTO Backup_Directory_Structure_Temp ( Directory, Directory_Short, Directory_Level, Timestamp_Indexed, Do_Not_Backup, Changes_Only, Timestamp_Backed_Up ) SELECT [Directory] & ""\"" AS Expr1, Backup_Directory_Structure.Directory_Short, Backup_Directory_Structure.Directory_Level, Backup_Directory_Structure.Timestamp_Indexed, Backup_Directory_Structure.Do_Not_Backup, Backup_Directory_Structure.Changes_Only, Backup_Directory_Structure.Timestamp_Backed_Up FROM Backup_Directory_Structure;")
0171Debug.Print Now() & " - Backup_Ctrl: Backup_Directory_Structure_Temp created"
0172'... Site_Map, ...
0173 DoCmd.OpenQuery ("Backup_Site_Map_Add")
0174 DoCmd.OpenQuery ("Backup_Site_Map_Updt")
0175If Backup_Changes_Since_Last_Run_Only = "No" Then
0176 'Only delete it it's not a "changes only" run (any deletions will be resolved next time there's a full run)
0177 DoCmd.RunSQL ("DELETE Backup_Site_Map_Zapper.* FROM Backup_Site_Map_Zapper;")
0178 DoCmd.OpenQuery ("Backup_Site_Map_Zapper_GEN")
0179 DoCmd.OpenQuery ("Backup_Site_Map_Zapper_DirectoryGone_GEN")
0180 DoCmd.OpenQuery ("Backup_Site_Map_Prune")
0181End If
0182Debug.Print Now() & " - Backup_Ctrl: Backup Site Map updated"
0183'Tidy up Temp tables
0184 DoCmd.RunSQL ("DELETE Backup_Directory_Structure_Temp.* FROM Backup_Directory_Structure_Temp;")
0185 DoCmd.RunSQL ("DELETE Backup_Site_Map_Temp.* FROM Backup_Site_Map_Temp;")
0186DoCmd.SetWarnings (True)
0187 Set rst = db.OpenRecordset("SELECT Count(Backup_Site_Map.FIle_Name) AS CountOfFIle_Name FROM Backup_Site_Map WHERE (((Backup_Site_Map.Directory) Like ""*" & Check_Directory & "*""));")
0188rst.MoveFirst
0189RecordsPost = rst.Fields(0)
0190Set rst = Nothing
0191 Set rst2 = db.OpenRecordset("SELECT Backup_Control.* FROM Backup_Control;")
0192Run_Duration = Now() - Start_Time
0193If Not rst2.EOF Then
0194 rst2.MoveFirst
0195 rst2.Edit
0196 rst2.Fields(0) = Start_Time
0197 rst2.Fields(3) = Round(Run_Duration * 24, 2)
0198 rst2.Fields(4) = Files_Processed
0199 rst2.Update
0200End If
0201'Add a record to the Backup History file
0202 Set rst = db.OpenRecordset("SELECT Backup_History.* FROM Backup_History WHERE Backup_History.Input_Root = """";")
0203rst.AddNew
0204For i = 0 To rst.Fields.Count - 1
0205 rst.Fields(i) = rst2.Fields(i)
0206Next i
0207rst.Update
0208Set rst = Nothing
0209Set rst2 = Nothing
0210Run_Duration = Run_Duration * 24
0211Debug.Print Now() & " - Backup_Ctrl: Backup complete"
0212If Run_Duration < 1 Then
0213 Run_Duration_Text = Round(Run_Duration * 60, 2) & " minutes"
0214Else
0215 Run_Duration_Text = Round(Run_Duration, 2) & " hours"
0216End If
0217strMsg = "Backup completed at " & Now() & " in " & Run_Duration_Text & "."
0218strMsg = strMsg & Chr$(10) & "Files processed = " & Files_Processed & ", Files backed-up = " & Backup_Files_Backed_Up & "."
0219strMsg = strMsg & Chr$(10) & "Records Prior = " & RecordsPrior & ", Records Post = " & RecordsPost & ", difference = " & RecordsPost - RecordsPrior & "."
0220Backup_Copy_Time = Round(Backup_Copy_Time * 24 * 60, 1)
0221strMsg = strMsg & Chr$(10) & "Time spent copying files = " & Backup_Copy_Time & " minutes."
0222 If (Backup_Errors + Backup_Errors_Full) > 0 Then
0223 DoCmd.RunSQL ("SELECT Backup_Site_Map_List.Backup_Site_Map_Object, Backup_Errors.Object_Timestamp, Backup_Errors.Object_Timestamp FROM Backup_Errors INNER JOIN Backup_Site_Map_List ON Backup_Errors.Backup_Object = Backup_Site_Map_List.Backup_Site_Map_Object WHERE (((Backup_Errors.Object_Timestamp) > " & Start_Time & "And ((Backup_Errors.Object_Timestamp) <> [Backup_Site_Map_List]![File_Timestamp])) ORDER BY Backup_Site_Map_List.Backup_Site_Map_Object;")
0224 strMsg = strMsg & Chr$(10) & "There were " & (Backup_Errors + Backup_Errors_Full) & " errors. Please investigate the Backup_Error_Table. "
0225 DoCmd.OpenTable ("Backup_Errors")
0226End If
0227Debug.Print Now() & " - Backup_Ctrl: " & strMsg
0228MsgBox (strMsg)
0229End Sub

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


Source Code of: Backup_Scurry
Procedure Type: Public Function
Module: Backups
Lines of Code: 281
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Backup_Scurry(DirectoryName, DirectoryLevel_In, Optional No_Backup)
0002Dim rst As Recordset
0003Dim rst2 As Recordset
0004Dim db As Database
0005Dim OK As String
0006Dim Check_File As String
0007Dim fs As Object
0008Dim fso As FileSystemObject
0009Dim Directory_Out As String
0010Dim MainFolder
0011Dim FileCollection
0012Dim File
0013Dim File_Name As String
0014Dim x As Long
0015Dim DirectoryLevel As Integer
0016Dim File_Timestamp As Date
0017Dim Updates_Only As String
0018Dim File_Wanted As String
0019Dim Start_Parsing_Time As Single
0020Dim End_Parsing_Time As Single
0021Dim Where_Are_We As String
0022Dim No_Backup_Now
0023Dim No_Backup_Later
0024Dim strMsg As String
0025Dim Response
0026Dim TransferName As String
0027Dim TempDirectory As String
0028Dim SiteMapDirectory As String
0029Dim From_Date_Found As String
0030Dim From_Date As Date
0031Dim Check_Directory As String
0032Dim Wanted_for_Backup As Boolean
0033Dim Backup_Time As Double
0034Const Backup_Errors_Max As Integer = 50
0035'This is a recursive Sub - ie. it calls itself
0036Backup_Scurry = "OK"
0037Where_Are_We = "Top"
0038DirectoryLevel = DirectoryLevel_In + 1
0039Set fs = CreateObject("Scripting.FileSystemObject")
0040Set fso = CreateObject("Scripting.FileSystemObject")
0041On Error GoTo Report_Error
0042Set db = CurrentDb
0043'Allow for stopping the Backup mid-flight (eg. if it's taking ages) while allowing an orderly shut-down
0044'Note: Need a second copy of MS Access open for this to work
0045 Set rst2 = db.OpenRecordset("SELECT Backup_Control.* FROM Backup_Control;")
0046If Not rst2.EOF Then
0047 rst2.MoveFirst
0048 If rst2.Fields(2).Value = "Yes" Then
0049 Stop
0050 Exit Function
0051 End If
0052End If
0053Set rst2 = Nothing
0054'Backup
0055TempDirectory = DirectoryName
0056If Backup_Changes_Since_Last_Run_Only = "Yes" Then
0057 'Changes-Only backup ... need to determine the "From Date" for this directory
0058 Set rst2 = db.OpenRecordset("SELECT Backup_History.Input_Root, Backup_History.Backup_Run_Date FROM Backup_History WHERE (((Backup_History.Index_Only) = ""No"")) ORDER BY Backup_History.Backup_Run_Date DESC;")
0059 If Not rst2.EOF Then
0060 rst2.MoveFirst
0061 From_Date_Found = "No"
0062 From_Date = Backup_Last_Run_Date
0063 Do Until From_Date_Found = "Yes"
0064 Check_Directory = rst2.Fields(0)
0065 If Right(Check_Directory, 1) <> "\" Then
0066 Check_Directory = Check_Directory & "\"
0067 End If
0068 If Len(Check_Directory) <= Len(DirectoryName) Then
0069 If Left(DirectoryName, Len(Check_Directory)) = Check_Directory Then
0070 From_Date_Found = "Yes"
0071 From_Date = rst2.Fields(1)
0072 End If
0073 End If
0074 If Not rst2.EOF Then
0075 rst2.MoveNext
0076 Else
0077 From_Date_Found = "Yes"
0078 End If
0079 Loop
0080 End If
0081End If
0082 Set rst2 = db.OpenRecordset("SELECT Backup_Directory_Structure.Do_Not_Backup, Backup_Directory_Structure.Changes_Only FROM Backup_Directory_Structure WHERE Backup_Directory_Structure.Directory =""" & TempDirectory & """;")
0083'Backup items in this directory?
0084If IsMissing(No_Backup) Then
0085 No_Backup_Now = "No"
0086Else
0087 No_Backup_Now = No_Backup
0088End If
0089If Not rst2.EOF Then
0090 If rst2.Fields(0).Value = "Yes" Or No_Backup_Now = "Yes" Then 'We don't ...
0091 'Sub-directories are "No_Backup" if a direcory is, except for the main directory (else nothing would be done!)
0092 If DirectoryLevel_In = 0 Then
0093 No_Backup_Later = "No"
0094 Else
0095 No_Backup_Later = "Yes"
0096 End If
0097 Set MainFolder = fso.GetFolder(DirectoryName)
0098 GoTo Recursion
0099 End If
0100End If
0101No_Backup_Later = "No" 'Ie. We do want to Backup sub-directories, unless specifically over-ridden
0102'We do ... ! Now note if "Updates Only" for this Directory
0103If Not rst2.EOF Then
0104 Updates_Only = rst2.Fields(1).Value
0105Else
0106 Updates_Only = "No"
0107End If
0108Set rst2 = Nothing
0109Set MainFolder = fso.GetFolder(DirectoryName)
0110Set FileCollection = MainFolder.Files
0111'Main Folders
0112On Error Resume Next
0113'This is a backup, so "lose" the "C:\" prefix
0114TempDirectory = Backup_Root_Directory & Mid(DirectoryName, 4, Len(DirectoryName))
0115'Create backup (or restore) directory
0116fs.CreateFolder (TempDirectory)
0117On Error GoTo Report_Error
0118For Each File In FileCollection
0119 File_Wanted = "Yes"
0120 File_Name = File.Name
0121 File_Timestamp = File.DateLastModified
0122 If Updates_Only = "Yes" And Backup_Changes_Since_Last_Run_Only = "Yes" Then
0123 If File_Timestamp < From_Date Then
0124 File_Wanted = "No"
0125 End If
0126 End If
0127 If File_Wanted = "Yes" Then
0128 'Check if large files are to be backed up
0129 If File.Size / 1000000 > Backup_Mb_Check Then
0130 Set rst2 = db.OpenRecordset("SELECT Backup_Site_Map.* FROM Backup_Site_Map WHERE (((Backup_Site_Map.Directory)=""" & DirectoryName & """) AND ((Backup_Site_Map.File_Name)=""" & File_Name & """));")
0131 If Not rst2.EOF Then
0132 rst2.MoveFirst
0133 If rst2.Fields(4).Value = "Yes" Then 'Check if file (as distinct from the directory) is not to be processed
0134 File_Wanted = "No"
0135 End If
0136 End If
0137 End If
0138 Set rst2 = Nothing
0139 End If
0140 Start_Parsing_Time = Now()
0141 'Log file stats
0142 SiteMapDirectory = DirectoryName
0143 Set rst2 = db.OpenRecordset("SELECT Backup_Site_Map_Temp.* FROM Backup_Site_Map_Temp WHERE (((Backup_Site_Map_Temp.Directory)=""" & SiteMapDirectory & """) AND ((Backup_Site_Map_Temp.File_Name)=""" & File_Name & """));")
0144 If rst2.EOF Then
0145 On Error GoTo Report_Error
0146 Where_Are_We = "Bug_1"
0147 rst2.AddNew
0148 rst2.Fields(0) = SiteMapDirectory
0149 rst2.Fields(1) = File_Name
0150 rst2.Fields(2) = Now()
0151 rst2.Fields(3) = File.Size
0152 rst2.Fields(4) = "No"
0153 If File_Wanted = "Yes" Then
0154 End_Parsing_Time = Now() 'Used to be "Timer"; why?
0155 rst2.Fields(5) = (End_Parsing_Time - Start_Parsing_Time) * 1000
0156 Else
0157 rst2.Fields(5) = 0
0158 End If
0159 rst2.Fields(6) = SiteMapDirectory & File_Name
0160 rst2.Fields(7) = File_Timestamp
0161 rst2.Update
0162 Files_Processed = Files_Processed + 1
0163Bug_1_Return:
0164 End If
0165 Set rst2 = Nothing
0166 Where_Are_We = "Bug_3"
0167 If File_Wanted = "Yes" Then
0168 'We'll start the backup here ...
0169 On Error GoTo Report_Error
0170 'Only back-up Website files if the parameters so indicate ...
0171 Wanted_for_Backup = True
0172 If Left(DirectoryName, Len(Backup_Website_Root_Directory)) = Backup_Website_Root_Directory Then
0173 If Backup_Website = False Then
0174 Wanted_for_Backup = False
0175 End If
0176 End If
0177 'Don't try to backup transfer files!
0178 TransferName = TempDirectory & File_Name
0179 If Left(DirectoryName & File_Name, Len("C:\Theo's Files\Websites\Transfer\")) = "C:\Theo's Files\Websites\Transfer\" Then
0180 Wanted_for_Backup = False
0181 End If
0182 If Wanted_for_Backup = True Then
0183 Backup_Time = Now()
0184 If Dir(TransferName) <> "" Then 'If we already have a file in the backup directory, then zap it
0185 Kill TransferName
0186 End If
0187 Where_Are_We = "Bug_4"
0188 fs.CopyFile DirectoryName & File_Name, TransferName
0189 Backup_Time = Now() - Backup_Time
0190 Backup_Copy_Time = Backup_Copy_Time + Backup_Time
0191 Backup_Files_Backed_Up = Backup_Files_Backed_Up + 1
0192 End If
0193 Where_Are_We = "Bug_5"
0194Bug_3_Return:
0195 End If
0196Next File
0197Recursion:
0198Set FileCollection = MainFolder.SubFolders
0199For Each File In FileCollection
0200 Where_Are_We = "Bug_2"
0201 Err.Clear
0202 On Error GoTo Report_Error
0203 File_Name = File.Name
0204 Directory_Out = DirectoryName & File_Name & "\"
0205 TempDirectory = DirectoryName
0206 'Write out a record (to Backup_Directory_Structure_Temp) for each sub-directory ... if not already there (can it be?)
0207 Set rst2 = db.OpenRecordset("SELECT Backup_Directory_Structure_Temp.* FROM Backup_Directory_Structure_Temp WHERE Backup_Directory_Structure_Temp.Directory =""" & TempDirectory & File_Name & "\" & """;")
0208 If rst2.EOF Then
0209 rst2.AddNew
0210 rst2.Fields(0) = TempDirectory & File_Name & "\"
0211 rst2.Fields(1) = File_Name
0212 rst2.Fields(2) = DirectoryLevel
0213 rst2.Fields(3) = Now()
0214 rst2.Fields(6) = Now()
0215 rst2.Fields(7) = File.DateLastModified
0216 rst2.Update
0217 End If
0218 Set rst2 = Nothing
0219 'Recursion ...
0220 OK = Backup_Scurry(Directory_Out, DirectoryLevel, No_Backup_Later)
0221 On Error GoTo Report_Error
0222Bug_2_Return:
0223Next File
0224GoTo Tidy_Up
0225Report_Error:
0226 Backup_Errors = Backup_Errors + 1
0227'Update error file
0228 Set rst = db.OpenRecordset("SELECT Backup_Errors.* FROM Backup_Errors;")
0229rst.AddNew
0230rst.Fields(1) = Err.Number
0231rst.Fields(2) = Err.Description
0232rst.Fields(3) = SiteMapDirectory & File_Name
0233Select Case Where_Are_We
0234 Case "Bug_1"
0235 rst.Fields(4) = Where_Are_We & ": Backup_Site_Map_Temp"
0236 Case "Bug_2"
0237 rst.Fields(4) = Where_Are_We & ": Backup_Directory_Structure_Temp"
0238 Case "Bug_3"
0239 rst.Fields(4) = Where_Are_We & ": Back-up File - Kill"
0240 Case "Bug_4"
0241 rst.Fields(4) = Where_Are_We & ": Back-up File - Copy"
0242 Case Else
0243End Select
0244rst.Fields(5) = Now()
0245rst.Fields(6) = File_Timestamp
0246rst.Update
0247Set rst = Nothing
0248If Backup_Errors_Stop = False Then
0249 If Backup_Errors > Backup_Errors_Max Then
0250 Backup_Errors_Full = Backup_Errors_Full + Backup_Errors
0251 strMsg = Now() & ": Backup_Scurry - There have been " & Backup_Errors & " errors since the last of these messages (if any) - respond ""Yes"" to continue with more of these messages, ""No"" to continue without any more of these messages or ""Cancel"" to abort. "
0252 Response = MsgBox(strMsg, vbYesNoCancel)
0253 If Response = vbCancel Then
0254 Stop
0255 End
0256 Else
0257 If Response = vbNo Then
0258 Backup_Errors_Stop = True
0259 End If
0260 End If
0261 Backup_Errors = 0
0262 End If
0263End If
0264Err.Clear
0265On Error GoTo Report_Error
0266Select Case Where_Are_We
0267 Case "Bug_1"
0268 Resume Bug_1_Return
0269 Case "Bug_2"
0270 Resume Bug_2_Return
0271 Case "Bug_3", "Bug_4"
0272 Resume Bug_3_Return
0273 Case Else
0274 Stop
0275End Select
0276Tidy_Up:
0277Set rst2 = Nothing
0278Set rst = Nothing
0279Set MainFolder = Nothing
0280Set FileCollection = Nothing
0281End Function

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


Source Code of: cmdAuthorNarrUpdt_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 47
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Private Sub cmdAuthorNarrUpdt_Click()
0002Dim StartTime As Date
0003Dim rsTableToRead As Recordset
0004Dim Response As String
0005Dim Author As String
0006Dim Blurb As String
0007Dim Run_Type As String
0008Response = MsgBox("Do you want to regenerate pages for a particular Authors or Authors?", vbYesNoCancel)
0009If Response = vbYes Then
0010 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM Author_Parameter;")
0011 If rsTableToRead.EOF Then
0012 DoCmd.OpenTable ("Author_Parameter")
0013 MsgBox ("Update the Author_Parameter Table.")
0014 End
0015 Else
0016 rsTableToRead.MoveFirst
0017 Author = rsTableToRead.Fields(0).Value
0018 rsTableToRead.MoveLast
0019 If rsTableToRead.RecordCount = 1 Then
0020 Blurb = Author
0021 Else
0022 Blurb = rsTableToRead.RecordCount & " authors from " & Author & " to " & rsTableToRead.Fields(0)
0023 End If
0024 Response = MsgBox("Do you want to run for " & Blurb & "? If not, update the Author_Parameter Table.", vbYesNoCancel)
0025 If Response = vbYes Then
0026 strDataQuery = "Authors_List_Selected_Authors"
0027 Else
0028 DoCmd.OpenTable ("Author_Parameter")
0029 End
0030 End If
0031 End If
0032Else
0033 End
0034End If
0035StartTime = Now()
0036 strControlTable = "Authors"
0037strOutputFileShort = "Author"
0038strOutputFolder = TheoWebsiteRoot & "\Authors\"
0039strOutputFile = ""
0040Run_Type = "Regen"
0041 CreateAuthorsWebPages (Run_Type)
0042MsgBox "Author pages Complete, in " & Round((Now() - StartTime) * 24 * 60, 1) & " minutes.", vbOKOnly, "Create Author Pages"
0043If MsgBox("Do you want to regenerate the Authors Summary pages?", vbYesNo) = vbYes Then
0044 WebpageGenAuthorsSummary
0045 MsgBox ("Authors Summary Pages produced OK")
0046End If
0047End Sub

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


Source Code of: cmdSearchAuthorNarrs_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 16

Line-No. / Ref.Code Line
0001Private Sub cmdSearchAuthorNarrs_Click()
0002Dim Response As String
0003Response = MsgBox("Do you want to add an Author?", vbYesNoCancel)
0004If Response = vbYes Then
0005 DoCmd.OpenTable ("Authors")
0006 MsgBox ("Update the Authors Table.")
0007 End
0008Else
0009 If Response = vbNo Then
0010 Response = MsgBox("Do you want to update an Author?", vbYesNo)
0011 If Response = vbYes Then
0012 DoCmd.OpenQuery ("AuthorNarrs - Search for Update")
0013 End If
0014 End If
0015End If
0016End Sub

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


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