Line-No. / Ref. | Code Line |
0001 | Public Function Compact_Repair(Slave_Database) |
0002 | Dim je As New JRO.JetEngine |
0003 | Dim fs As Object |
0004 | Dim db As Database |
0005 | Dim rst As Recordset |
0006 | Dim DatabaseName As String |
0007 | Dim DatabaseName_Temp As String |
0008 | Dim DatabaseName_Check As String |
0009 | Dim DD As String |
0010 | Dim MM As String |
0011 | Dim yy As String |
0012 | Dim Found_It As String |
0013 | Dim i As Integer |
0014 | Dim iFileSize As Long |
0015 | Dim strMsg As String |
0016 | DD = Right(100 + Day(Now()), 2) |
0017 | MM = Right(100 + Month(Now()), 2) |
0018 | yy = Right(Year(Now()), 2) |
0019 | DatabaseName = Slave_Database & ".accdb" |
0020 | DatabaseName_Check = Slave_Database & "_Temp_" & yy & MM & DD |
0021 | DatabaseName_Temp = DatabaseName_Check & ".accdb" |
0022 | 'Find the next free name |
0023 | i = 1 |
0024 | Found_It = "No" |
0025 | Do Until Found_It = "Yes" |
0026 | If Dir(DatabaseName_Temp) <> "" Then |
0027 | DatabaseName_Temp = DatabaseName_Check & "_" & i & ".accdb" |
0028 | i = i + 1 |
0029 | Else |
0030 | Found_It = "Yes" |
0031 | End If |
0032 | Loop |
0033 | Set fs = CreateObject("Scripting.FileSystemObject") |
0034 | iFileSize = fs.GetFile(DatabaseName).Size |
0035 | iFileSize = Round(iFileSize / 1000000, 0) |
0036 | If iFileSize > Max_Database_Size Then |
0037 | strMsg = ". WARNING: Database size exceeds system parameter of " & Max_Database_Size & "Mb and approaches the 2Gb limit!" |
0038 | Else |
0039 | strMsg = "" |
0040 | End If |
0041 | Debug.Print Now() & " - Compact_Repair: Prior File Size = " & iFileSize & "Mb" & strMsg |
0042 | If Dir(Slave_Database & ".laccdb") = "" Then |
0043 | If Dir(DatabaseName_Temp) <> "" Then |
0044 | Kill DatabaseName_Temp |
0045 | End If |
0046 | Compact_Repair = _ |
0047 | Application.CompactRepair( _ |
0048 | LogFile:=True, _ |
0049 | SourceFile:=DatabaseName, _ |
0050 | DestinationFile:=DatabaseName_Temp) |
0051 | Kill DatabaseName |
0052 | fs.CopyFile DatabaseName_Temp, DatabaseName |
0053 | Else |
0054 | strMsg = Now() & " - Database " & Slave_Database & ".accdb is locked and cannot be compacted/repaired." |
0055 | Debug.Print strMsg |
0056 | MsgBox (strMsg) |
0057 | Stop |
0058 | End If |
0059 | iFileSize = fs.GetFile(DatabaseName).Size |
0060 | Debug.Print Now() & " - Compact_Repair: Post File Size = " & Round(iFileSize / 1000000, 0) & "Mb" |
0061 | Compact_Repair = "OK" |
0062 | Set db = Nothing |
0063 | Set fs = Nothing |
0064 | Set rst = Nothing |
0065 | Set je = Nothing |
0066 | End Function |
Line-No. / Ref. | Code Line |
0001 | Public Sub Full_Link_Up_Levels_Gen() |
0002 | Dim rst As Recordset |
0003 | Dim rst2 As Recordset |
0004 | Dim db As Database |
0005 | Dim strQuery As String |
0006 | Dim Directory As String |
0007 | Dim Directory_Saved As String |
0008 | Dim strLink_Type As String |
0009 | Dim strLink_Type_Saved As String |
0010 | Dim Full_Link As String |
0011 | Dim Start_Pos As Integer |
0012 | Dim Updates_Done As Long |
0013 | Dim Full_Directory As String |
0014 | Set db = CurrentDb |
0015 | Updates_Done = 0 |
0016 | DoCmd.SetWarnings (False) |
0017 | strQuery = "SELECT Raw_Links.* FROM Raw_Links WHERE (((Raw_Links.Link_Type) Like ""*level*"") AND ((Raw_Links.Full_Link) Is Null));" |
0018 | Set rst = db.OpenRecordset(strQuery) |
0019 | Directory_Saved = "xxx" |
0020 | strLink_Type_Saved = "xxx" |
0021 | If Not rst.EOF Then |
0022 | rst.MoveFirst |
0023 | Do While Not rst.EOF |
0024 | ' Check if we need to C/R the slave database |
0025 | If Updates_Done > 200000 Then |
0026 | Updates_Done = 0 |
0027 | Set rst = Nothing |
0028 | Compact_Repair ("C:\Theo's Files\Birkbeck\Web_Generator_Performance") |
0029 | strQuery = "SELECT Raw_Links.* FROM Raw_Links WHERE (((Raw_Links.Link_Type) Like ""*level*"") AND ((Raw_Links.Full_Link) Is Null));" |
0030 | Set rst = db.OpenRecordset(strQuery) |
0031 | rst.MoveFirst |
0032 | End If |
0033 | Directory = rst.Fields(0).Value |
0034 | strLink_Type = rst.Fields(5).Value |
0035 | If (Directory <> Directory_Saved) Or (strLink_Type <> strLink_Type_Saved) Then |
0036 | Directory_Saved = Directory |
0037 | strLink_Type_Saved = strLink_Type |
0038 | Select Case strLink_Type |
0039 | Case "Up 1 Level" |
0040 | Start_Pos = 4 |
0041 | Case "Up 2 Levels" |
0042 | Start_Pos = 7 |
0043 | Case "Up 3 Levels" |
0044 | Start_Pos = 10 |
0045 | Case "Up 4 Levels" |
0046 | Start_Pos = 13 |
0047 | Case "Up 5 Levels" |
0048 | Start_Pos = 16 |
0049 | Case "Up 6 Levels" |
0050 | Start_Pos = 19 |
0051 | Case "Up 7 Levels" |
0052 | Start_Pos = 22 |
0053 | End Select |
0054 | strQuery = "SELECT Directory_Fine_Structure.Result_Directory FROM Directory_Fine_Structure WHERE (((Directory_Fine_Structure.Base_Directory)=""" & Directory & """) AND ((Directory_Fine_Structure.Backup_Level)=""" & strLink_Type & """));" |
0055 | Set rst2 = db.OpenRecordset(strQuery) |
0056 | If Not rst2.EOF Then |
0057 | rst2.MoveFirst |
0058 | Full_Directory = rst2.Fields(0).Value |
0059 | Else |
0060 | Full_Directory = "***Missing***" |
0061 | End If |
0062 | End If |
0063 | If Not Full_Directory = "***Missing***" Then |
0064 | Full_Link = Full_Directory & Replace(Mid(rst.Fields(2).Value, Start_Pos, 300), "/", "\") |
0065 | rst.Edit |
0066 | rst.Fields(3) = Full_Link |
0067 | rst.Update |
0068 | Updates_Done = Updates_Done + 1 |
0069 | Else |
0070 | Debug.Print Now() & " - Spider: Full_Link_Up_Levels_Gen Error. Directory_Fine_Structure. Directory = " & Directory & " " & strLink_Type & " missing" |
0071 | End If |
0072 | Set rst2 = Nothing |
0073 | rst.MoveNext |
0074 | Loop |
0075 | End If |
0076 | End Sub |
Line-No. / Ref. | Code Line |
0001 | Public Sub Spider_Ctrl() |
0002 | Dim OK As String |
0003 | Dim Start_Time As Date |
0004 | Dim rst2 As Recordset |
0005 | Dim db As Database |
0006 | Dim Links_Before As Long |
0007 | Dim Links_After As Long |
0008 | Dim Run_Duration As Single |
0009 | Dim strMessage As String |
0010 | MsgBox ("Click when ready") |
0011 | Set db = CurrentDb |
0012 | Start_Time = Now() |
0013 | Last_Compact = Start_Time |
0014 | Links_Added = 0 |
0015 | Files_Processed = 0 |
0016 | DoCmd.RunSQL ("DELETE Directory_Structure_Temp.* FROM Directory_Structure_Temp;") |
0017 | DoCmd.RunSQL ("DELETE Site_Map_Temp.* FROM Site_Map_Temp;") |
0018 | DoCmd.RunSQL ("DELETE Raw_Links_Temp.* FROM Raw_Links_Temp;") |
0019 | DoCmd.RunSQL ("DELETE Raw_Links_Temp_Temp.* FROM Raw_Links_Temp_Temp;") |
0020 | Set rsSpider_Temp_Links = db.OpenRecordset("SELECT Raw_Links_Temp_Temp.* FROM Raw_Links_Temp_Temp;") |
0021 | Set rst2 = db.OpenRecordset("SELECT Spider_Control.* FROM Spider_Control;") |
0022 | If Not rst2.EOF Then |
0023 | rst2.MoveFirst |
0024 | Spider_Last_Run_Date = rst2.Fields(0).Value |
0025 | Spider_Since_Last_Only = rst2.Fields(1).Value |
0026 | strMessage = Now() & " - Spider_Ctrl: 'Updates Since Last Run Only' parameter set to '" & Spider_Since_Last_Only & "'" |
0027 | Debug.Print strMessage |
0028 | End If |
0029 | Set rst2 = Nothing |
0030 | Set rst2 = db.OpenRecordset("SELECT Count(Raw_Links.Directory) AS CountOfDirectory FROM Raw_Links;") |
0031 | If Not rst2.EOF Then |
0032 | rst2.MoveFirst |
0033 | Links_Before = rst2.Fields(0).Value |
0034 | End If |
0035 | Set rst2 = Nothing |
0036 | OK = Check_Database_Size() |
0037 | strMessage = Now() & " - Spider_Ctrl: Entering Spider_Scurry" |
0038 | strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)" |
0039 | Debug.Print strMessage |
0040 | OK = Spider_Scurry(TheoWebsiteRoot, 0) |
0041 | 'To get round the "Insufficient memory or disk space, you won't be able to undo; continue?" problem in the following update queries:- |
0042 | 'a) Set the query propery UseTransaction to "No" (this still produces the message, but speeds things up) |
0043 | 'b) Set warnings off, as in Spider_Scurry below |
0044 | OK = Check_Database_Size() |
0045 | strMessage = Now() & " - Spider_Ctrl: Returned from Spider_Scurry" |
0046 | strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)" |
0047 | Debug.Print strMessage |
0048 | 'Copy the Temp files to the Slave Database |
0049 | Spider_Copy |
0050 | OK = Check_Database_Size() |
0051 | strMessage = Now() & " - Spider_Ctrl: Returned from Spider_Copy" |
0052 | strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)" |
0053 | Debug.Print strMessage |
0054 | 'Determine link-count |
0055 | Set rst2 = db.OpenRecordset("SELECT Count(Raw_Links.Directory) AS CountOfDirectory FROM Raw_Links;") |
0056 | If Not rst2.EOF Then |
0057 | rst2.MoveFirst |
0058 | Links_After = rst2.Fields(0).Value |
0059 | End If |
0060 | Set rst2 = Nothing |
0061 | 'Refresh the external links page ... |
0062 | 'DoCmd.OpenQuery ("Webrefs_Add") ... seems to be adding spurious " |
0063 | Set rst2 = db.OpenRecordset("SELECT Webrefs_To_Be_Added_By_Spider.* FROM Webrefs_To_Be_Added_By_Spider;") |
0064 | If Not rst2.EOF Then |
0065 | If rst2.RecordCount > 0 Then |
0066 | DoCmd.OpenQuery ("Webrefs_To_Be_Added_By_Spider_Detail") |
0067 | DoCmd.OpenQuery ("Webrefs_To_Be_Added_By_Spider") |
0068 | Debug.Print Now() & " - Spider_Ctrl: Check ""Webrefs_To_Be_Added_By_Spider_Detail"" and run ""Webrefs_Add"" if necessary." |
0069 | End If |
0070 | End If |
0071 | Set rst2 = Nothing |
0072 | automatic_processing = "Yes" |
0073 | WebRefs_Checker_Pages_Gen |
0074 | Set rst2 = db.OpenRecordset("SELECT Spider_Control.* FROM Spider_Control;") |
0075 | Run_Duration = Round((Now() - Start_Time) * 24, 2) |
0076 | If Not rst2.EOF Then |
0077 | rst2.MoveFirst |
0078 | rst2.Edit |
0079 | rst2.Fields(0) = Start_Time |
0080 | rst2.Fields(3) = Run_Duration |
0081 | rst2.Fields(4) = Files_Processed |
0082 | rst2.Fields(5) = Links_Before |
0083 | rst2.Fields(6) = Links_Added |
0084 | rst2.Fields(7) = Links_After |
0085 | rst2.Update |
0086 | End If |
0087 | Set rst2 = Nothing |
0088 | Set rsSpider_Temp_Links = Nothing |
0089 | 'Output the timings crosstab |
0090 | Spider_Scurry_Log_Timings_Gen |
0091 | OK = Check_Database_Size() |
0092 | strMessage = Now() & " - Spider completed in " & Run_Duration & " hours. Files processed = " & Files_Processed & ". Links before = " & Links_Before & ". Links adjusted = " & Links_Added & ". Links after = " & Links_After & "." |
0093 | Debug.Print strMessage |
0094 | strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)" |
0095 | MsgBox ("Spider completed at " & strMessage) |
0096 | End Sub |
Line-No. / Ref. | Code Line |
0001 | Public Function Spider_Scurry(DirectoryName, DirectoryLevel_In, Optional No_Parsing) |
0002 | Dim rst As Recordset |
0003 | Dim rst2 As Recordset |
0004 | Dim db As Database |
0005 | Dim OK As String |
0006 | Dim fso As FileSystemObject |
0007 | Dim tsTextFileIn As TextStream |
0008 | Dim strLine As String |
0009 | Dim strLineMore As String |
0010 | Dim InFile As String |
0011 | Dim Directory_Out As String |
0012 | Dim MainFolder |
0013 | Dim FileCollection |
0014 | Dim File |
0015 | Dim File_Name As String |
0016 | Dim Y As Long |
0017 | Dim z As Long |
0018 | Dim zzz As Long |
0019 | Dim strLinkStart As String |
0020 | Dim strLinkEnd As String |
0021 | Dim LenstrLinkStart As Long |
0022 | Dim strQuery As String |
0023 | Dim DirectoryLevel As Integer |
0024 | Dim FoundWhatsit As String |
0025 | Dim File_Timestamp As Date |
0026 | Dim FileExtension As String |
0027 | Dim Link_Out As String |
0028 | Dim LenstrLine As Long |
0029 | Dim LenstrLineMore As Long |
0030 | Dim Updates_Only As String |
0031 | Dim File_Wanted As String |
0032 | Dim Start_Parsing_Time As Single |
0033 | Dim End_Parsing_Time As Single |
0034 | Dim Where_Are_We As String |
0035 | Dim No_Parsing_Now |
0036 | Dim No_Parsing_Later |
0037 | Dim strMsg As String |
0038 | Dim strDirectory As String |
0039 | 'Parse items in this directory? |
0040 | If IsMissing(No_Parsing) Then |
0041 | No_Parsing_Now = "No" |
0042 | Else |
0043 | No_Parsing_Now = No_Parsing |
0044 | End If |
0045 | 'This is a recursive Sub - ie. it calls itself |
0046 | OK = Spider_Scurry_Log_Timestamps("Enter", Now(), DirectoryName, DirectoryLevel_In, No_Parsing_Now) |
0047 | Spider_Scurry = "OK" |
0048 | Where_Are_We = "Top" |
0049 | DirectoryLevel = DirectoryLevel_In + 1 |
0050 | On Error GoTo Report_Error |
0051 | Set db = CurrentDb |
0052 | Set rst2 = db.OpenRecordset("SELECT Spider_Control.* FROM Spider_Control;") |
0053 | If Not rst2.EOF Then |
0054 | rst2.MoveFirst |
0055 | If rst2.Fields(2).Value = "Yes" Then |
0056 | 'This allows for stopping the Spider mid-flight (eg. if it's taking ages) while allowing an orderly shut-down. |
0057 | Set rst2 = Nothing |
0058 | Exit Function |
0059 | End If |
0060 | End If |
0061 | Set rst2 = Nothing |
0062 | Set fso = CreateObject("Scripting.FileSystemObject") |
0063 | 'Check what we need to do .... |
0064 | Set rst2 = db.OpenRecordset("SELECT Directory_Structure.Do_Not_Parse, Directory_Structure.Updates_Only FROM Directory_Structure WHERE Directory_Structure.Directory =""" & DirectoryName & """;") |
0065 | If Not rst2.EOF Then |
0066 | If rst2.Fields(0).Value = "Yes" Or No_Parsing_Now = "Yes" Then 'We don't ... |
0067 | DirectoryName = DirectoryName & "\" |
0068 | 'Sub-directories are "No_Parsing" if a direcory is, except for the main directory (else nothing would be done!) |
0069 | If DirectoryLevel_In = 0 Then |
0070 | No_Parsing_Later = "No" |
0071 | Else |
0072 | No_Parsing_Later = "Yes" |
0073 | End If |
0074 | Set MainFolder = fso.GetFolder(DirectoryName) |
0075 | GoTo Recursion |
0076 | End If |
0077 | 'Now note if "Updates Only" for this Directory |
0078 | Updates_Only = rst2.Fields(1).Value |
0079 | Else |
0080 | 'New directory |
0081 | Updates_Only = "No" |
0082 | End If |
0083 | No_Parsing_Later = "No" 'Ie. We do want to parse sub-directories, unless specifically over-ridden |
0084 | Set rst2 = Nothing |
0085 | 'Add the root directory on first pass |
0086 | If DirectoryLevel_In = 0 Then |
0087 | Set rst2 = db.OpenRecordset("SELECT Directory_Structure_Temp.* FROM Directory_Structure_Temp WHERE Directory_Structure_Temp.Directory =""" & DirectoryName & """;") |
0088 | If rst2.EOF Then |
0089 | rst2.AddNew |
0090 | strDirectory = Replace(DirectoryName, TheoWebsiteRoot, "") |
0091 | If strDirectory & "" = "" Then |
0092 | strDirectory = "\" |
0093 | End If |
0094 | rst2.Fields(0) = strDirectory |
0095 | rst2.Fields(1) = "" |
0096 | rst2.Fields(2) = 0 |
0097 | rst2.Fields(3) = Now() |
0098 | rst2.Update |
0099 | End If |
0100 | Set rst2 = Nothing |
0101 | End If |
0102 | If DirectoryName <> "\" Then |
0103 | DirectoryName = DirectoryName & "\" |
0104 | End If |
0105 | Set MainFolder = fso.GetFolder(DirectoryName) |
0106 | Set FileCollection = MainFolder.Files |
0107 | strLinkStart = "HREF" |
0108 | strLinkEnd = """" |
0109 | LenstrLinkStart = Len(strLinkStart) |
0110 | For Each File In FileCollection |
0111 | File_Wanted = "Yes" |
0112 | File_Name = File.Name |
0113 | File_Timestamp = File.DateLastModified |
0114 | If Updates_Only = "Yes" Or Spider_Since_Last_Only = "Yes" Then |
0115 | If Spider_Since_Last_Only = "Yes" Then 'System Parameter for whole directory structure |
0116 | If File_Timestamp < Spider_Last_Run_Date Then |
0117 | File_Wanted = "No" |
0118 | End If |
0119 | Else |
0120 | 'So, check everything, but not this directory unless there's a reason for checking this file |
0121 | strQuery = "SELECT Raw_Links.Directory, Raw_Links.File_Name, Max(Raw_Links.Timestamp_Logged) AS MaxOfTimestamp_Logged FROM Raw_Links GROUP BY Raw_Links.Directory, Raw_Links.File_Name HAVING (((Raw_Links.Directory)=""" & DirectoryName & """) AND ((Raw_Links.File_Name)=""" & File_Name & """));" |
0122 | Set rst = db.OpenRecordset(strQuery) |
0123 | If Not rst.EOF Then |
0124 | '... ie. it definitely hasn't changed? Can't use Spider_Last_Run_Date as might not have checked this directory last time. |
0125 | rst.MoveFirst |
0126 | If File_Timestamp < rst.Fields(2).Value Then |
0127 | File_Wanted = "No" |
0128 | End If |
0129 | End If |
0130 | Set rst = Nothing |
0131 | End If |
0132 | End If |
0133 | If File_Wanted = "Yes" Then |
0134 | Set rst2 = db.OpenRecordset("SELECT Site_Map.* FROM Site_Map WHERE (((Site_Map.Directory)=""" & Replace(DirectoryName, TheoWebsiteRoot, "") & """) AND ((Site_Map.File_Name)=""" & File_Name & """));") |
0135 | If Not rst2.EOF Then |
0136 | rst2.MoveFirst |
0137 | If rst2.Fields(4).Value = "Yes" Then 'Check if file (as distinct from the directory) is not to be processed |
0138 | File_Wanted = "No" |
0139 | End If |
0140 | End If |
0141 | Set rst2 = Nothing |
0142 | End If |
0143 | FileExtension = UCase(Mid(File_Name, 1 + InStr(1, File_Name, "."), 20)) |
0144 | If FileExtension = "HTM" Or FileExtension = "HTML" Or FileExtension = "SHTM" Or FileExtension = "SHTML" Then |
0145 | Else |
0146 | File_Wanted = "Log" |
0147 | End If |
0148 | If File_Wanted = "Yes" Then |
0149 | Start_Parsing_Time = Timer |
0150 | InFile = DirectoryName & File_Name |
0151 | If File.Size < 5 Then 'Arbitrary check for degenerate files where .ReadLine fails |
0152 | strLine = " " |
0153 | Else |
0154 | Set tsTextFileIn = fso.OpenTextFile(InFile, ForReading, True, True) 'Open the file |
0155 | strLine = tsTextFileIn.ReadLine |
0156 | Do Until tsTextFileIn.AtEndOfStream |
0157 | LenstrLine = Len(strLine) |
0158 | strLineMore = tsTextFileIn.ReadLine |
0159 | LenstrLineMore = Len(strLineMore) |
0160 | strLine = strLine & strLineMore |
0161 | If (LenstrLine + LenstrLineMore <> Len(strLine)) Then |
0162 | 'Probably superfluous check for text overflow |
0163 | MsgBox (LenstrLine) |
0164 | Stop |
0165 | End If |
0166 | Loop |
0167 | End If |
0168 | 'Now parse the file and write out a record for each link |
0169 | FoundWhatsit = "Yes" |
0170 | zzz = 1 |
0171 | Do Until FoundWhatsit = "No" |
0172 | z = InStr(1, strLine, strLinkStart, vbTextCompare) |
0173 | Do While z > 0 And zzz > 0 |
0174 | zzz = InStr(z + 1, strLine, "=", vbTextCompare) |
0175 | If (zzz = 0) Or (zzz - LenstrLinkStart - z > 3) Then |
0176 | zzz = z + LenstrLinkStart |
0177 | Link_Out = "Defective" |
0178 | z = zzz |
0179 | Else |
0180 | Y = zzz |
0181 | zzz = InStr(zzz + 1, strLine, """", vbTextCompare) |
0182 | If (zzz = 0) Or (zzz - Y > 3) Then |
0183 | zzz = z + LenstrLinkStart |
0184 | Link_Out = "Defective" |
0185 | z = zzz |
0186 | Else |
0187 | Y = zzz |
0188 | zzz = InStr(Y + 1, strLine, strLinkEnd, vbTextCompare) |
0189 | If zzz > 0 Then 'If found |
0190 | If (zzz - Y) < 2 Then |
0191 | Link_Out = "Null" |
0192 | Else |
0193 | Link_Out = Mid(strLine, Y + 1, zzz - Y - 1) |
0194 | z = zzz + 1 |
0195 | End If |
0196 | Else |
0197 | Link_Out = "Missing" |
0198 | zzz = Y + LenstrLinkStart |
0199 | End If |
0200 | End If |
0201 | End If |
0202 | 'Write out a record |
0203 | Where_Are_We = "Bug_3" |
0204 | rsSpider_Temp_Links.AddNew |
0205 | rsSpider_Temp_Links.Fields(0) = Replace(DirectoryName, TheoWebsiteRoot, "") |
0206 | rsSpider_Temp_Links.Fields(1) = File_Name |
0207 | rsSpider_Temp_Links.Fields(2) = Left(Link_Out, 255) 'Note ... this represents a bug in the HTML ... need to report better |
0208 | rsSpider_Temp_Links.Update |
0209 | Links_Added = Links_Added + 1 |
0210 | Bug_3_Return: |
0211 | If zzz > 0 Then |
0212 | z = InStr(zzz, strLine, strLinkStart, vbTextCompare) |
0213 | Else |
0214 | z = 0 |
0215 | End If |
0216 | Loop |
0217 | FoundWhatsit = "No" |
0218 | Loop |
0219 | Else |
0220 | File_Wanted = "Log" |
0221 | End If |
0222 | If File_Wanted = "Yes" Or File_Wanted = "Log" Then |
0223 | 'Log file stats |
0224 | Set rst2 = db.OpenRecordset("SELECT Site_Map_Temp.* FROM Site_Map_Temp WHERE (((Site_Map_Temp.Directory)=""" & DirectoryName & """) AND ((Site_Map_Temp.File_Name)=""" & File_Name & """));") |
0225 | If rst2.EOF Then |
0226 | Where_Are_We = "Bug_1" |
0227 | rst2.AddNew |
0228 | rst2.Fields(0) = Replace(DirectoryName, TheoWebsiteRoot, "") |
0229 | rst2.Fields(1) = File_Name |
0230 | rst2.Fields(2) = Now() |
0231 | rst2.Fields(3) = File.Size |
0232 | If File_Wanted = "Yes" Then |
0233 | End_Parsing_Time = Timer |
0234 | rst2.Fields(5) = (End_Parsing_Time - Start_Parsing_Time) * 1000 |
0235 | rst2.Fields(8) = True |
0236 | Else |
0237 | rst2.Fields(5) = 0 |
0238 | rst2.Fields(8) = False |
0239 | End If |
0240 | rst2.Fields(6) = Replace(DirectoryName, TheoWebsiteRoot, "") & Replace(File_Name, "/", "\") |
0241 | rst2.Fields(7) = File_Timestamp |
0242 | rst2.Update |
0243 | Files_Processed = Files_Processed + 1 |
0244 | Bug_1_Return: |
0245 | End If |
0246 | Set rst2 = Nothing |
0247 | End If |
0248 | Next File |
0249 | Recursion: |
0250 | Set FileCollection = MainFolder.SubFolders |
0251 | For Each File In FileCollection |
0252 | File_Name = File.Name |
0253 | Directory_Out = DirectoryName & File_Name |
0254 | 'Write out a record |
0255 | '... if not already there (can it be?) |
0256 | Set rst2 = db.OpenRecordset("SELECT Directory_Structure_Temp.* FROM Directory_Structure_Temp WHERE Directory_Structure_Temp.Directory =""" & Directory_Out & """;") |
0257 | If rst2.EOF Then |
0258 | rst2.AddNew |
0259 | rst2.Fields(0) = Replace(Directory_Out, TheoWebsiteRoot, "") |
0260 | rst2.Fields(1) = File_Name |
0261 | rst2.Fields(2) = DirectoryLevel |
0262 | rst2.Fields(3) = Now() |
0263 | rst2.Update |
0264 | End If |
0265 | Set rst2 = Nothing |
0266 | 'Recursion ... |
0267 | OK = Spider_Scurry(Directory_Out, DirectoryLevel, No_Parsing_Later) |
0268 | OK = Spider_Scurry_Log_Timestamps("Return", Now(), Directory_Out, DirectoryLevel, No_Parsing_Later) |
0269 | Next File |
0270 | GoTo Tidy_Up |
0271 | Report_Error: |
0272 | strMsg = Now() & " - " & Where_Are_We & ": Error " & Err.Number & " (" & Err.Description & "), file " & File_Name & " - respond ""OK"" or ""Cancel"". ""OK"" will STOP and allow you to take a look and still terminate if you want. " |
0273 | Debug.Print strMsg |
0274 | If MsgBox(strMsg, vbOKCancel) = vbCancel Then |
0275 | End |
0276 | Else |
0277 | Stop |
0278 | Err.Clear |
0279 | On Error GoTo Report_Error |
0280 | Select Case Where_Are_We |
0281 | Case "Bug_1" |
0282 | GoTo Bug_1_Return |
0283 | Case "Bug_3" |
0284 | GoTo Bug_3_Return |
0285 | End Select |
0286 | End If |
0287 | Tidy_Up: |
0288 | Set rst2 = Nothing |
0289 | Set rst = Nothing |
0290 | Set MainFolder = Nothing |
0291 | Set FileCollection = Nothing |
0292 | End Function |