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: 69
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 Slash_Pos = InStr(Slash_Pos + 1, Source_Directory, "\")
0025 If Slash_Pos > 0 Then
0026 Slash_Count = Slash_Count + 1
0027 End If
0028 Loop
0029 'Add new dummy link
0030 Slash_Pos = 1
0031 Base_Directory = Source_Directory
0032 For i = 1 To Slash_Count
0033 Slash_Pos = InStr(Slash_Pos + 1, Source_Directory, "\")
0034 Result_Directory = Left(Source_Directory, Slash_Pos)
0035 Back_Count = Slash_Count - i
0036 Select Case Back_Count
0037 Case 0
0038 Backup_Level = "Up 1 Level"
0039 Case 1
0040 Backup_Level = "Up 2 Levels"
0041 Case 2
0042 Backup_Level = "Up 3 Levels"
0043 Case 3
0044 Backup_Level = "Up 4 Levels"
0045 Case 4
0046 Backup_Level = "Up 5 Levels"
0047 Case 5
0048 Backup_Level = "Up 6 Levels"
0049 Case 6
0050 Backup_Level = "Up 7 Levels"
0051 End Select
0052 'Is it already logged?
0053 strQuery = "Select * from Directory_Fine_Structure Where Directory_Fine_Structure!Base_Directory=""" & Base_Directory & "\" & """ And Directory_Fine_Structure!Backup_Level=""" & Backup_Level & """;"
0054 Set rst2 = db.OpenRecordset(strQuery)
0055 If rst2.EOF Then
0056 'No ... so add it
0057 rst2.AddNew
0058 rst2.Fields(0) = Base_Directory & "\"
0059 rst2.Fields(1) = Backup_Level
0060 rst2.Fields(2) = Result_Directory
0061 rst2.Fields(3) = Now()
0062 rst2.Update
0063 End If
0064 Set rst2 = Nothing
0065 Next i
0066 rst.MoveNext
0067 Loop
0068End If
0069End 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("C:\Theo's Files\Websites\Theo's Website", 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: 284
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
0038'Parse items in this directory?
0039If IsMissing(No_Parsing) Then
0040 No_Parsing_Now = "No"
0041Else
0042 No_Parsing_Now = No_Parsing
0043End If
0044'This is a recursive Sub - ie. it calls itself
0045 OK = Spider_Scurry_Log_Timestamps("Enter", Now(), DirectoryName, DirectoryLevel_In, No_Parsing_Now)
0046Spider_Scurry = "OK"
0047Where_Are_We = "Top"
0048DirectoryLevel = DirectoryLevel_In + 1
0049On Error GoTo Report_Error
0050Set db = CurrentDb
0051 Set rst2 = db.OpenRecordset("SELECT Spider_Control.* FROM Spider_Control;")
0052If Not rst2.EOF Then
0053 rst2.MoveFirst
0054 If rst2.Fields(2).Value = "Yes" Then
0055 'This allows for stopping the Spider mid-flight (eg. if it's taking ages) while allowing an orderly shut-down.
0056 Exit Function
0057 End If
0058End If
0059Set rst2 = Nothing
0060Set fso = CreateObject("Scripting.FileSystemObject")
0061'Check what we need to do ....
0062 Set rst2 = db.OpenRecordset("SELECT Directory_Structure.Do_Not_Parse, Directory_Structure.Updates_Only FROM Directory_Structure WHERE Directory_Structure.Directory =""" & DirectoryName & """;")
0063If Not rst2.EOF Then
0064 If rst2.Fields(0).Value = "Yes" Or No_Parsing_Now = "Yes" Then 'We don't ...
0065 DirectoryName = DirectoryName & "\"
0066 'Sub-directories are "No_Parsing" if a direcory is, except for the main directory (else nothing would be done!)
0067 If DirectoryLevel_In = 0 Then
0068 No_Parsing_Later = "No"
0069 Else
0070 No_Parsing_Later = "Yes"
0071 End If
0072 Set MainFolder = fso.GetFolder(DirectoryName)
0073 GoTo Recursion
0074 End If
0075 'Now note if "Updates Only" for this Directory
0076 Updates_Only = rst2.Fields(1).Value
0077Else
0078 'New directory
0079 Updates_Only = "No"
0080End If
0081No_Parsing_Later = "No" 'Ie. We do want to parse sub-directories, unless specifically over-ridden
0082Set rst2 = Nothing
0083'Add the root directory on first pass
0084If DirectoryLevel_In = 0 Then
0085 Set rst2 = db.OpenRecordset("SELECT Directory_Structure_Temp.* FROM Directory_Structure_Temp WHERE Directory_Structure_Temp.Directory =""" & DirectoryName & """;")
0086 If rst2.EOF Then
0087 rst2.AddNew
0088 rst2.Fields(0) = DirectoryName
0089 rst2.Fields(1) = ""
0090 rst2.Fields(2) = 0
0091 rst2.Fields(3) = Now()
0092 rst2.Update
0093 End If
0094 Set rst2 = Nothing
0095End If
0096DirectoryName = DirectoryName & "\"
0097Set MainFolder = fso.GetFolder(DirectoryName)
0098Set FileCollection = MainFolder.Files
0099strLinkStart = "HREF"
0100strLinkEnd = """"
0101LenstrLinkStart = Len(strLinkStart)
0102For Each File In FileCollection
0103 File_Wanted = "Yes"
0104 File_Name = File.Name
0105 File_Timestamp = File.DateLastModified
0106 If Updates_Only = "Yes" Or Spider_Since_Last_Only = "Yes" Then
0107 If Spider_Since_Last_Only = "Yes" Then 'System Parameter for whole directory structure
0108 If File_Timestamp < Spider_Last_Run_Date Then
0109 File_Wanted = "No"
0110 End If
0111 Else
0112 'So, check everything, but not this directory unless there's a reason for checking this file
0113 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 & """));"
0114 Set rst = db.OpenRecordset(strQuery)
0115 If Not rst.EOF Then
0116 '... ie. it definitely hasn't changed? Can't use Spider_Last_Run_Date as might not have checked this directory last time.
0117 rst.MoveFirst
0118 If File_Timestamp < rst.Fields(2).Value Then
0119 File_Wanted = "No"
0120 End If
0121 End If
0122 Set rst = Nothing
0123 End If
0124 End If
0125 If File_Wanted = "Yes" Then
0126 Set rst2 = db.OpenRecordset("SELECT Site_Map.* FROM Site_Map WHERE (((Site_Map.Directory)=""" & DirectoryName & """) AND ((Site_Map.File_Name)=""" & File_Name & """));")
0127 If Not rst2.EOF Then
0128 rst2.MoveFirst
0129 If rst2.Fields(4).Value = "Yes" Then 'Check if file (as distinct from the directory) is not to be processed
0130 File_Wanted = "No"
0131 End If
0132 End If
0133 Set rst2 = Nothing
0134 End If
0135 FileExtension = UCase(Mid(File_Name, 1 + InStr(1, File_Name, "."), 20))
0136 If FileExtension = "HTM" Or FileExtension = "HTML" Or FileExtension = "SHTM" Or FileExtension = "SHTML" Then
0137 Else
0138 File_Wanted = "Log"
0139 End If
0140 If File_Wanted = "Yes" Then
0141 Start_Parsing_Time = Timer
0142 InFile = DirectoryName & File_Name
0143 If File.Size < 5 Then 'Arbitrary check for degenerate files where .ReadLine fails
0144 strLine = " "
0145 Else
0146 Set tsTextFileIn = fso.OpenTextFile(InFile, ForReading, True, True) 'Open the file
0147 strLine = tsTextFileIn.ReadLine
0148 Do Until tsTextFileIn.AtEndOfStream
0149 LenstrLine = Len(strLine)
0150 strLineMore = tsTextFileIn.ReadLine
0151 LenstrLineMore = Len(strLineMore)
0152 strLine = strLine & strLineMore
0153 If (LenstrLine + LenstrLineMore <> Len(strLine)) Then
0154 'Probably superfluous check for text overflow
0155 MsgBox (LenstrLine)
0156 Stop
0157 End If
0158 Loop
0159 End If
0160 'Now parse the file and write out a record for each link
0161 FoundWhatsit = "Yes"
0162 zzz = 1
0163 Do Until FoundWhatsit = "No"
0164 z = InStr(1, strLine, strLinkStart, vbTextCompare)
0165 Do While z > 0 And zzz > 0
0166 zzz = InStr(z + 1, strLine, "=", vbTextCompare)
0167 If (zzz = 0) Or (zzz - LenstrLinkStart - z > 3) Then
0168 zzz = z + LenstrLinkStart
0169 Link_Out = "Defective"
0170 z = zzz
0171 Else
0172 Y = zzz
0173 zzz = InStr(zzz + 1, strLine, """", vbTextCompare)
0174 If (zzz = 0) Or (zzz - Y > 3) Then
0175 zzz = z + LenstrLinkStart
0176 Link_Out = "Defective"
0177 z = zzz
0178 Else
0179 Y = zzz
0180 zzz = InStr(Y + 1, strLine, strLinkEnd, vbTextCompare)
0181 If zzz > 0 Then 'If found
0182 If (zzz - Y) < 2 Then
0183 Link_Out = "Null"
0184 Else
0185 Link_Out = Mid(strLine, Y + 1, zzz - Y - 1)
0186 z = zzz + 1
0187 End If
0188 Else
0189 Link_Out = "Missing"
0190 zzz = Y + LenstrLinkStart
0191 End If
0192 End If
0193 End If
0194 'Write out a record
0195 Where_Are_We = "Bug_3"
0196 rsSpider_Temp_Links.AddNew
0197 rsSpider_Temp_Links.Fields(0) = DirectoryName
0198 rsSpider_Temp_Links.Fields(1) = File_Name
0199 rsSpider_Temp_Links.Fields(2) = Left(Link_Out, 255) 'Note ... this represents a bug in the HTML ... need to report better
0200 rsSpider_Temp_Links.Update
0201 Links_Added = Links_Added + 1
0202Bug_3_Return:
0203 If zzz > 0 Then
0204 z = InStr(zzz, strLine, strLinkStart, vbTextCompare)
0205 Else
0206 z = 0
0207 End If
0208 Loop
0209 FoundWhatsit = "No"
0210 Loop
0211 Else
0212 File_Wanted = "Log"
0213 End If
0214 If File_Wanted = "Yes" Or File_Wanted = "Log" Then
0215 'Log file stats
0216 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 & """));")
0217 If rst2.EOF Then
0218 Where_Are_We = "Bug_1"
0219 rst2.AddNew
0220 rst2.Fields(0) = DirectoryName
0221 rst2.Fields(1) = File_Name
0222 rst2.Fields(2) = Now()
0223 rst2.Fields(3) = File.Size
0224 If File_Wanted = "Yes" Then
0225 End_Parsing_Time = Timer
0226 rst2.Fields(5) = (End_Parsing_Time - Start_Parsing_Time) * 1000
0227 rst2.Fields(8) = True
0228 Else
0229 rst2.Fields(5) = 0
0230 rst2.Fields(8) = False
0231 End If
0232 rst2.Fields(6) = DirectoryName & Replace(File_Name, "/", "\")
0233 rst2.Fields(7) = File_Timestamp
0234 rst2.Update
0235 Files_Processed = Files_Processed + 1
0236Bug_1_Return:
0237 End If
0238 Set rst2 = Nothing
0239 End If
0240Next File
0241Recursion:
0242Set FileCollection = MainFolder.SubFolders
0243For Each File In FileCollection
0244 File_Name = File.Name
0245 Directory_Out = DirectoryName & File_Name
0246 'Write out a record
0247 '... if not already there (can it be?)
0248 Set rst2 = db.OpenRecordset("SELECT Directory_Structure_Temp.* FROM Directory_Structure_Temp WHERE Directory_Structure_Temp.Directory =""" & Directory_Out & """;")
0249 If rst2.EOF Then
0250 rst2.AddNew
0251 rst2.Fields(0) = Directory_Out
0252 rst2.Fields(1) = File_Name
0253 rst2.Fields(2) = DirectoryLevel
0254 rst2.Fields(3) = Now()
0255 rst2.Update
0256 End If
0257 Set rst2 = Nothing
0258 'Recursion ...
0259 OK = Spider_Scurry(Directory_Out, DirectoryLevel, No_Parsing_Later)
0260 OK = Spider_Scurry_Log_Timestamps("Return", Now(), Directory_Out, DirectoryLevel, No_Parsing_Later)
0261Next File
0262GoTo Tidy_Up
0263Report_Error:
0264strMsg = 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. "
0265Debug.Print strMsg
0266If MsgBox(strMsg, vbOKCancel) = vbCancel Then
0267 End
0268Else
0269 Stop
0270 Err.Clear
0271 On Error GoTo Report_Error
0272 Select Case Where_Are_We
0273 Case "Bug_1"
0274 GoTo Bug_1_Return
0275 Case "Bug_3"
0276 GoTo Bug_3_Return
0277 End Select
0278End If
0279Tidy_Up:
0280Set rst2 = Nothing
0281Set rst = Nothing
0282Set MainFolder = Nothing
0283Set FileCollection = Nothing
0284End 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 - Sept 2022. 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