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: 56
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
0011Dim yy As String
0012Dim Found_It As String
0013Dim i As Integer
0014Dim iFileSize As Long
0015DD = Right(100 + Day(Now()), 2)
0016MM = Right(100 + Month(Now()), 2)
0017yy = Right(Year(Now()), 2)
0018DatabaseName = Slave_Database & ".accdb"
0019DatabaseName_Check = Slave_Database & "_Temp_" & yy & MM & DD
0020DatabaseName_Temp = DatabaseName_Check & ".accdb"
0021'Find the next free name
0022i = 1
0023Found_It = "No"
0024Do Until Found_It = "Yes"
0025 If Dir(DatabaseName_Temp) <> "" Then
0026 DatabaseName_Temp = DatabaseName_Check & "_" & i & ".accdb"
0027 i = i + 1
0028 Else
0029 Found_It = "Yes"
0030 End If
0031Loop
0032Set fs = CreateObject("Scripting.FileSystemObject")
0033iFileSize = fs.GetFile(DatabaseName).Size
0034Debug.Print Now() & " - Compact_Repair: Prior File Size = " & Round(iFileSize / 1000000, 0) & "Mb"
0035If Dir(Slave_Database & ".laccdb") = "" Then
0036 If Dir(DatabaseName_Temp) <> "" Then
0037 Kill DatabaseName_Temp
0038 End If
0039 Compact_Repair = _
0040 Application.CompactRepair( _
0041 LogFile:=True, _
0042 SourceFile:=DatabaseName, _
0043 DestinationFile:=DatabaseName_Temp)
0044 Kill DatabaseName
0045 fs.CopyFile DatabaseName_Temp, DatabaseName
0046Else
0047 MsgBox ("Database " & Slave_Database & ".accdb is locked and cannot be compacted/repaired.")
0048End If
0049iFileSize = fs.GetFile(DatabaseName).Size
0050Debug.Print Now() & " - Compact_Repair: Post File Size = " & Round(iFileSize / 1000000, 0) & "Mb"
0051Compact_Repair = "OK"
0052Set db = Nothing
0053Set fs = Nothing
0054Set rst = Nothing
0055Set je = Nothing
0056End Function

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