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 18 (6 items)

Compact_RepairLink_TypeSpider_ScurryDirectory_Fine_Structure_Gen
Full_Link_Up_Levels_GenSpider_Ctrl..

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

Go to top of page



Source Code of: Compact_Repair
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 66
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Compact_Repair(Slave_Database)
0002Dim je As New JRO.JetEngine
0003Dim fs As Object
0004Dim db As Database
0005Dim rst As Recordset
0006Dim DatabaseName As String
0007Dim DatabaseName_Temp As String
0008Dim DatabaseName_Check As String
0009Dim DD As String
0010Dim MM As String
0011 Dim yy As String
0012Dim Found_It As String
0013Dim i As Integer
0014Dim iFileSize As Long
0015Dim strMsg As String
0016DD = Right(100 + Day(Now()), 2)
0017MM = Right(100 + Month(Now()), 2)
0018 yy = Right(Year(Now()), 2)
0019DatabaseName = Slave_Database & ".accdb"
0020 DatabaseName_Check = Slave_Database & "_Temp_" & yy & MM & DD
0021DatabaseName_Temp = DatabaseName_Check & ".accdb"
0022'Find the next free name
0023i = 1
0024Found_It = "No"
0025Do 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
0032Loop
0033Set fs = CreateObject("Scripting.FileSystemObject")
0034iFileSize = fs.GetFile(DatabaseName).Size
0035iFileSize = Round(iFileSize / 1000000, 0)
0036If iFileSize > Max_Database_Size Then
0037 strMsg = ". WARNING: Database size exceeds system parameter of " & Max_Database_Size & "Mb and approaches the 2Gb limit!"
0038Else
0039 strMsg = ""
0040End If
0041Debug.Print Now() & " - Compact_Repair: Prior File Size = " & iFileSize & "Mb" & strMsg
0042If 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
0053Else
0054 strMsg = Now() & " - Database " & Slave_Database & ".accdb is locked and cannot be compacted/repaired."
0055 Debug.Print strMsg
0056 MsgBox (strMsg)
0057 Stop
0058End If
0059iFileSize = fs.GetFile(DatabaseName).Size
0060Debug.Print Now() & " - Compact_Repair: Post File Size = " & Round(iFileSize / 1000000, 0) & "Mb"
0061Compact_Repair = "OK"
0062Set db = Nothing
0063Set fs = Nothing
0064Set rst = Nothing
0065Set je = Nothing
0066End Function

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


Source Code of: Directory_Fine_Structure_Gen
Procedure Type: Public Sub
Module: Spider
Lines of Code: 72
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Directory_Fine_Structure_Gen()
0002Dim rst As Recordset
0003Dim rst2 As Recordset
0004Dim db As Database
0005Dim strQuery As String
0006Dim Source_Directory As String
0007Dim Base_Directory As String
0008Dim Backup_Level As String
0009Dim Result_Directory As String
0010Dim Slash_Pos As Integer
0011Dim Slash_Count As Integer
0012Dim i As Integer
0013Dim Back_Count As Integer
0014Set db = CurrentDb
0015 strQuery = "Select * from Directory_Structure;"
0016Set rst = db.OpenRecordset(strQuery)
0017If Not rst.EOF Then
0018 rst.MoveFirst
0019 Do While Not rst.EOF
0020 Source_Directory = rst.Fields(0).Value
0021 Slash_Pos = 1
0022 Slash_Count = 0
0023 Do While Slash_Pos > 0
0024 If Slash_Pos = 1 And Slash_Count = 0 Then
0025 Slash_Pos = 0
0026 End If
0027 Slash_Pos = InStr(Slash_Pos + 1, Source_Directory, "\")
0028 If Slash_Pos > 0 Then
0029 Slash_Count = Slash_Count + 1
0030 End If
0031 Loop
0032 'Add new dummy link
0033 Slash_Pos = 0
0034 Base_Directory = Source_Directory
0035 For i = 1 To Slash_Count
0036 Slash_Pos = InStr(Slash_Pos + 1, Source_Directory, "\")
0037 Result_Directory = Left(Source_Directory, Slash_Pos)
0038 Back_Count = Slash_Count - i
0039 Select Case Back_Count
0040 Case 0
0041 Backup_Level = "Up 1 Level"
0042 Case 1
0043 Backup_Level = "Up 2 Levels"
0044 Case 2
0045 Backup_Level = "Up 3 Levels"
0046 Case 3
0047 Backup_Level = "Up 4 Levels"
0048 Case 4
0049 Backup_Level = "Up 5 Levels"
0050 Case 5
0051 Backup_Level = "Up 6 Levels"
0052 Case 6
0053 Backup_Level = "Up 7 Levels"
0054 End Select
0055 'Is it already logged?
0056 strQuery = "Select * from Directory_Fine_Structure Where Directory_Fine_Structure!Base_Directory=""" & Base_Directory & "\" & """ And Directory_Fine_Structure!Backup_Level=""" & Backup_Level & """;"
0057 Set rst2 = db.OpenRecordset(strQuery)
0058 If rst2.EOF Then
0059 'No ... so add it
0060 rst2.AddNew
0061 rst2.Fields(0) = Base_Directory & "\"
0062 rst2.Fields(1) = Backup_Level
0063 rst2.Fields(2) = Result_Directory
0064 rst2.Fields(3) = Now()
0065 rst2.Update
0066 End If
0067 Set rst2 = Nothing
0068 Next i
0069 rst.MoveNext
0070 Loop
0071End If
0072End Sub

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


Source Code of: Full_Link_Up_Levels_Gen
Procedure Type: Public Sub
Module: Spider
Lines of Code: 76
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Full_Link_Up_Levels_Gen()
0002Dim rst As Recordset
0003Dim rst2 As Recordset
0004Dim db As Database
0005Dim strQuery As String
0006Dim Directory As String
0007Dim Directory_Saved As String
0008Dim strLink_Type As String
0009Dim strLink_Type_Saved As String
0010Dim Full_Link As String
0011Dim Start_Pos As Integer
0012Dim Updates_Done As Long
0013Dim Full_Directory As String
0014Set db = CurrentDb
0015Updates_Done = 0
0016DoCmd.SetWarnings (False)
0017 strQuery = "SELECT Raw_Links.* FROM Raw_Links WHERE (((Raw_Links.Link_Type) Like ""*level*"") AND ((Raw_Links.Full_Link) Is Null));"
0018Set rst = db.OpenRecordset(strQuery)
0019Directory_Saved = "xxx"
0020strLink_Type_Saved = "xxx"
0021If 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
0075End If
0076End Sub

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


Source Code of: Link_Type
Procedure Type: Public Function
Module: Spider
Lines of Code: 39
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Link_Type(Link_Type_Str)
0002If UCase(Left(Link_Type_Str, 4)) = "HTTP" Then
0003 Link_Type = "Web"
0004Else
0005 If UCase(Left(Trim(Link_Type_Str), 4)) = "HTTP" Then
0006 Link_Type = "Web - Leading Space"
0007 Else
0008 If UCase(Left(Link_Type_Str, 6)) = "MAILTO" Then
0009 Link_Type = "EMail"
0010 Else
0011 If Left(Link_Type_Str, 1) = "#" Then
0012 Link_Type = "Same Page"
0013 Else
0014 If Left(Link_Type_Str, 12) = "../../../../" Then
0015 Link_Type = "Up 4 Levels"
0016 Else
0017 If Left(Link_Type_Str, 9) = "../../../" Then
0018 Link_Type = "Up 3 Levels"
0019 Else
0020 If Left(Link_Type_Str, 6) = "../../" Then
0021 Link_Type = "Up 2 Levels"
0022 Else
0023 If Left(Link_Type_Str, 3) = "../" Then
0024 Link_Type = "Up 1 Level"
0025 Else
0026 If (UCase(Left(Link_Type_Str, 1)) >= "A") And (UCase(Left(Link_Type_Str, 1)) <= "Z") Then
0027 Link_Type = "Same Directory"
0028 Else
0029 Link_Type = "Other"
0030 End If
0031 End If
0032 End If
0033 End If
0034 End If
0035 End If
0036 End If
0037 End If
0038End If
0039End Function

Procedures Calling This Procedure (Link_Type) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page


Source Code of: Spider_Ctrl
Procedure Type: Public Sub
Module: Spider
Lines of Code: 96
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Spider_Ctrl()
0002Dim OK As String
0003Dim Start_Time As Date
0004Dim rst2 As Recordset
0005Dim db As Database
0006Dim Links_Before As Long
0007Dim Links_After As Long
0008Dim Run_Duration As Single
0009Dim strMessage As String
0010MsgBox ("Click when ready")
0011Set db = CurrentDb
0012Start_Time = Now()
0013Last_Compact = Start_Time
0014Links_Added = 0
0015Files_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;")
0022If 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
0028End If
0029Set rst2 = Nothing
0030 Set rst2 = db.OpenRecordset("SELECT Count(Raw_Links.Directory) AS CountOfDirectory FROM Raw_Links;")
0031If Not rst2.EOF Then
0032 rst2.MoveFirst
0033 Links_Before = rst2.Fields(0).Value
0034End If
0035Set rst2 = Nothing
0036 OK = Check_Database_Size()
0037strMessage = Now() & " - Spider_Ctrl: Entering Spider_Scurry"
0038 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0039Debug.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()
0045strMessage = Now() & " - Spider_Ctrl: Returned from Spider_Scurry"
0046 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0047Debug.Print strMessage
0048'Copy the Temp files to the Slave Database
0049 Spider_Copy
0050 OK = Check_Database_Size()
0051strMessage = Now() & " - Spider_Ctrl: Returned from Spider_Copy"
0052 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0053Debug.Print strMessage
0054'Determine link-count
0055 Set rst2 = db.OpenRecordset("SELECT Count(Raw_Links.Directory) AS CountOfDirectory FROM Raw_Links;")
0056If Not rst2.EOF Then
0057 rst2.MoveFirst
0058 Links_After = rst2.Fields(0).Value
0059End If
0060Set 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;")
0064If 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
0070End If
0071Set rst2 = Nothing
0072automatic_processing = "Yes"
0073 WebRefs_Checker_Pages_Gen
0074 Set rst2 = db.OpenRecordset("SELECT Spider_Control.* FROM Spider_Control;")
0075Run_Duration = Round((Now() - Start_Time) * 24, 2)
0076If 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
0086End If
0087Set rst2 = Nothing
0088Set rsSpider_Temp_Links = Nothing
0089'Output the timings crosstab
0090 Spider_Scurry_Log_Timings_Gen
0091 OK = Check_Database_Size()
0092strMessage = Now() & " - Spider completed in " & Run_Duration & " hours. Files processed = " & Files_Processed & ". Links before = " & Links_Before & ". Links adjusted = " & Links_Added & ". Links after = " & Links_After & "."
0093Debug.Print strMessage
0094 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0095MsgBox ("Spider completed at " & strMessage)
0096End Sub

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


Source Code of: Spider_Scurry
Procedure Type: Public Function
Module: Spider
Lines of Code: 292
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Spider_Scurry(DirectoryName, DirectoryLevel_In, Optional No_Parsing)
0002Dim rst As Recordset
0003Dim rst2 As Recordset
0004Dim db As Database
0005Dim OK As String
0006Dim fso As FileSystemObject
0007Dim tsTextFileIn As TextStream
0008Dim strLine As String
0009Dim strLineMore As String
0010Dim InFile As String
0011Dim Directory_Out As String
0012Dim MainFolder
0013Dim FileCollection
0014Dim File
0015Dim File_Name As String
0016Dim Y As Long
0017Dim z As Long
0018Dim zzz As Long
0019Dim strLinkStart As String
0020Dim strLinkEnd As String
0021Dim LenstrLinkStart As Long
0022Dim strQuery As String
0023Dim DirectoryLevel As Integer
0024Dim FoundWhatsit As String
0025Dim File_Timestamp As Date
0026Dim FileExtension As String
0027Dim Link_Out As String
0028Dim LenstrLine As Long
0029Dim LenstrLineMore As Long
0030Dim Updates_Only As String
0031Dim File_Wanted As String
0032Dim Start_Parsing_Time As Single
0033Dim End_Parsing_Time As Single
0034Dim Where_Are_We As String
0035Dim No_Parsing_Now
0036Dim No_Parsing_Later
0037Dim strMsg As String
0038Dim strDirectory As String
0039'Parse items in this directory?
0040If IsMissing(No_Parsing) Then
0041 No_Parsing_Now = "No"
0042Else
0043 No_Parsing_Now = No_Parsing
0044End 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)
0047Spider_Scurry = "OK"
0048Where_Are_We = "Top"
0049DirectoryLevel = DirectoryLevel_In + 1
0050On Error GoTo Report_Error
0051Set db = CurrentDb
0052 Set rst2 = db.OpenRecordset("SELECT Spider_Control.* FROM Spider_Control;")
0053If 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
0060End If
0061Set rst2 = Nothing
0062Set 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 & """;")
0065If 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
0079Else
0080 'New directory
0081 Updates_Only = "No"
0082End If
0083No_Parsing_Later = "No" 'Ie. We do want to parse sub-directories, unless specifically over-ridden
0084Set rst2 = Nothing
0085'Add the root directory on first pass
0086If 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
0101End If
0102If DirectoryName <> "\" Then
0103 DirectoryName = DirectoryName & "\"
0104End If
0105Set MainFolder = fso.GetFolder(DirectoryName)
0106Set FileCollection = MainFolder.Files
0107strLinkStart = "HREF"
0108strLinkEnd = """"
0109LenstrLinkStart = Len(strLinkStart)
0110For 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
0210Bug_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
0244Bug_1_Return:
0245 End If
0246 Set rst2 = Nothing
0247 End If
0248Next File
0249Recursion:
0250Set FileCollection = MainFolder.SubFolders
0251For 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)
0269Next File
0270GoTo Tidy_Up
0271Report_Error:
0272strMsg = 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. "
0273Debug.Print strMsg
0274If MsgBox(strMsg, vbOKCancel) = vbCancel Then
0275 End
0276Else
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
0286End If
0287Tidy_Up:
0288Set rst2 = Nothing
0289Set rst = Nothing
0290Set MainFolder = Nothing
0291Set FileCollection = Nothing
0292End Function

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


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