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 5 (9 items)

Find_New_DirectoryMark_ColoursReference_AuthorReference_Code
Reference_ReferenceAuto_Reference_Notes_RegenBB_Control_GENClear_Colour_Usage
Spider_Copy...

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

Go to top of page



Source Code of: Auto_Reference_Notes_Regen
Procedure Type: Public Sub
Module: Testing
Lines of Code: 60
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Auto_Reference_Notes_Regen(Optional Auto)
0002Dim rs As Recordset
0003Dim strQuery As String
0004Dim Duration As Single
0005Dim RunStartTime As Date
0006Dim iUpdates_Total As Integer
0007Dim Estimated_Run_Time As Single
0008Dim Update_Start As Double
0009Dim Auto_Local As Boolean
0010If IsMissing(Auto) Then
0011 Auto_Local = False
0012Else
0013 Auto_Local = IIf(Auto = "Yes", True, False)
0014End If
0015iUpdates_Total = 0
0016Estimated_Run_Time = 0
0017 strQuery = "SELECT Note_Alternates.ID, Note_Alternates.[Auto_Link?], Note_Alternates.Item_Alt_Title, Note_Alternates.Item_Title, Note_Alternates.Last_Auto_Link_Run, Note_Alternates.Regen_Time FROM Note_Alternates WHERE (((Note_Alternates.Item_Alt_Title) = [Item_Title]) And ((Note_Alternates.Last_Auto_Link_Run) Is Not Null)) ORDER BY Note_Alternates.ID;"
0018Set rs = CurrentDb.OpenRecordset(strQuery)
0019rs.MoveFirst
0020Do While Not rs.EOF
0021 iUpdates_Total = iUpdates_Total + 1
0022 Estimated_Run_Time = Estimated_Run_Time + Nz(rs.Fields(5))
0023 If rs.Fields(1) = True Then
0024 rs.Edit
0025 rs.Fields(1) = False
0026 rs.Update
0027 End If
0028 rs.MoveNext
0029Loop
0030If automatic_processing <> "Yes" Then
0031 If MsgBox(iUpdates_Total & " files to update; estimated time = " & Round(Estimated_Run_Time, 1) & " minutes. Continue?", vbYesNo) <> vbYes Then
0032 End
0033 End If
0034End If
0035automatic_processing = "Yes"
0036'Now regenerate
0037RunStartTime = Now()
0038rs.MoveFirst
0039Do While Not rs.EOF
0040 rs.Edit
0041 rs.Fields(1) = True
0042 rs.Update
0043 Update_Start = Now()
0044 Auto_Reference_Notes (Auto_Local)
0045 rs.Edit
0046 rs.Fields(1) = False
0047 rs.Fields(5) = 24 * 60 * (Now() - Update_Start)
0048 rs.Update
0049 rs.MoveNext
0050Loop
0051 Set rs = CurrentDb.OpenRecordset("SELECT * FROM BookPaperControl WHERE ID = ""Auto_Reference_Notes_Regen"";")
0052Duration = Round((Now() - RunStartTime) * 24 * 60, 1)
0053rs.Edit
0054rs.Fields(1) = Now()
0055rs.Fields(2) = Duration
0056rs.Update
0057If Auto_Local = False Then
0058 MsgBox "Automatic Note Linkages Regen Completed in " & Duration & " minutes. " & iUpdates_Total & " pages output.", vbOKOnly, "Automatic Note Linkages"
0059End If
0060End Sub

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


Source Code of: BB_Control_GEN
Procedure Type: Public Sub
Module: General_Subroutines
Lines of Code: 57
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub BB_Control_GEN()
0002Dim rst As Recordset
0003Dim db As Database
0004Dim i As Long
0005Dim RecordCount As Long
0006Dim MaxRecordCount As Long
0007Dim PB As String
0008Dim PB_Last As String
0009Dim Splitsize As Integer
0010Dim Level As Integer
0011Dim Splitcount As String
0012Splitsize = 5
0013MaxRecordCount = 1000 '... This is to circumvent MaxLocksPerFile errors. It's the maximum number of records to be updated in a go, after which there's a commit.
0014RecordCount = 0
0015Level = 1
0016Do While Level < 6
0017 If RecordCount > 0 Then
0018 DBEngine.CommitTrans
0019 End If
0020 RecordCount = 0
0021 Splitcount = 1
0022 Set db = CurrentDb
0023 Set rst = db.OpenRecordset("Select * from BB_Control order by Primary_Break;")
0024 DBEngine.BeginTrans
0025 rst.MoveFirst
0026 i = 1
0027 PB_Last = ""
0028 Do While Not rst.EOF
0029 PB = rst.Fields(Level) 'This is actually the level below the one we're currently updating
0030 If PB <> PB_Last Then
0031 If (Splitcount > Splitsize) Or (Level = 1) Then
0032 i = i + 1
0033 Splitcount = 1
0034 Else
0035 Splitcount = Splitcount + 1
0036 End If
0037 PB_Last = PB
0038 End If
0039 rst.Edit
0040 rst.Fields(Level + 1) = i
0041 rst.Update
0042 RecordCount = RecordCount + 1
0043 If RecordCount > MaxRecordCount Then
0044 DBEngine.CommitTrans
0045 DBEngine.BeginTrans
0046 RecordCount = 0
0047 End If
0048 rst.MoveNext
0049 Loop
0050 Splitcount = 1
0051 Level = Level + 1
0052Loop
0053If RecordCount > 0 Then
0054 DBEngine.CommitTrans
0055End If
0056Set rst = Nothing
0057End Sub

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


Source Code of: Clear_Colour_Usage
Procedure Type: Public Sub
Module: General_Functions
Lines of Code: 6

Line-No. / Ref.Code Line
0001Public Sub Clear_Colour_Usage()
0002Dim i As Integer
0003For i = 0 To 19 'Clear the Saved Array
0004 Colour_Table(i, 4) = "0"
0005Next i
0006End Sub

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


Source Code of: Find_New_Directory
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 6

Line-No. / Ref.Code Line
0001Public Function Find_New_Directory(Note_ID)
0002'This is the (simple) calculation of the Notes directory from the ID - a function in case it changes
0003Dim strDirectory As String
0004strDirectory = Int(Note_ID / 100)
0005Find_New_Directory = strDirectory
0006End Function

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


Source Code of: Mark_Colours
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 79
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Mark_Colours(strText)
0002Dim x As Long
0003Dim Y As Long
0004Dim ColourRef As String
0005Dim strText_Local As String
0006Dim strText_Start As String
0007Dim strText_Middle As String
0008Dim strText_End As String
0009Dim qryString As String
0010Dim rsTableToRead As Recordset
0011Dim i As Integer
0012If Len(strText) = 0 Then
0013 Mark_Colours = "Not Found"
0014 Exit Function
0015End If
0016i = 0
0017strText_Local = strText
0018x = 1
0019x = InStr(x, UCase(strText_Local), "|COLOUR_")
0020Mark_Colours = "Not Found"
0021Do While x > 0
0022 strText_Start = Left(strText_Local, x - 1)
0023 Mark_Colours = "Found"
0024 Y = InStr(x + 1, strText_Local, "|")
0025 ColourRef = Mid(strText_Local, x + 8, Y - x - 8)
0026 If Y > Len(strText_Local) - 2 Then
0027 strText_End = ""
0028 Else
0029 strText_End = Mid(strText_Local, Y + 1, Len(strText_Local))
0030 End If
0031 If ColourRef = "R" Then
0032 strText_Middle = "</FONT>"
0033 Else
0034 'Determine Colour Title
0035 If Val(ColourRef) >= 0 And ColourRef < 20 Then
0036 'Colour_Table
0037 If Colour_Table(0, 0) & "" = "" Then
0038 For i = 0 To 19 'Clear the Saved Array
0039 Colour_Table(i, 0) = ""
0040 Colour_Table(i, 1) = ""
0041 Colour_Table(i, 2) = ""
0042 Colour_Table(i, 3) = ""
0043 Colour_Table(i, 4) = "0"
0044 Next i
0045 'Populate Colour_Table
0046 Colour_Table(0, 0) = "0"
0047 Colour_Table(0, 1) = "000000"
0048 Colour_Table(0, 2) = "Black"
0049 Colour_Table(0, 3) = "Printable Text by me; &copy; Theo Todman, " & Year(Now())
0050 Colour_Table(0, 4) = "0"
0051 qryString = "SELECT Colours.* FROM Colours;"
0052 Set rsTableToRead = CurrentDb.OpenRecordset(qryString)
0053 If Not rsTableToRead.EOF Then
0054 rsTableToRead.MoveFirst
0055 Do While Not rsTableToRead.EOF
0056 Colour_Table(rsTableToRead.Fields(0), 0) = rsTableToRead.Fields(0)
0057 Colour_Table(rsTableToRead.Fields(0), 1) = rsTableToRead.Fields(1)
0058 Colour_Table(rsTableToRead.Fields(0), 2) = rsTableToRead.Fields(2)
0059 Colour_Table(rsTableToRead.Fields(0), 3) = Replace(rsTableToRead.Fields(3), "YYYY", Year(Now()))
0060 Colour_Table(rsTableToRead.Fields(0), 4) = "0"
0061 rsTableToRead.MoveNext
0062 Loop
0063 End If
0064 Set rsTableToRead = Nothing
0065 End If
0066 strText_Middle = "<FONT COLOR = """ & Colour_Table(Val(ColourRef), 1) & """>"
0067 'Flag colour used
0068 Colour_Table(Val(ColourRef), 4) = 1
0069 Else
0070 strText_Middle = ""
0071 MsgBox ("Unknown colour ID = """ & ColourRef & """")
0072 Stop
0073 End If
0074 End If
0075 strText_Local = strText_Start & strText_Middle & strText_End
0076 x = InStr(x, strText_Local, "|Colour_")
0077Loop
0078strText = strText_Local
0079End Function

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


Source Code of: Reference_Author
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 129
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Reference_Author(strText, Calling_Type, Calling_ID, Calling_Timestamp, Optional Depth)
0002Dim x As Long
0003Dim Y As Long
0004Dim AuthorRef As String
0005Dim strText_Local As String
0006Dim strText_End As String
0007Dim qryString As String
0008Dim rsTableToRead As Recordset
0009Dim AuthorLink As String
0010Dim AuthorDirectory As String
0011Dim strName As String
0012Dim iDepth As Integer
0013Dim strPrefix As String
0014Dim i As Integer
0015Dim Calling_ID_Local As Integer
0016Dim Author_ID As Integer
0017Dim AuthorDisplay As String
0018Dim Author_Comma As Boolean
0019Dim Author_Reformat As String
0020Dim j As Integer
0021Dim k As Integer
0022If Len(strText) = 0 Then
0023 Reference_Author = "Not Found"
0024 Exit Function
0025End If
0026If IsMissing(Depth) Then
0027 iDepth = 2
0028Else
0029 iDepth = Depth
0030End If
0031i = 0
0032strPrefix = ""
0033Do While i < iDepth
0034 strPrefix = strPrefix & "../"
0035 i = i + 1
0036Loop
0037strText_Local = strText
0038x = 1
0039x = InStr(x, strText_Local, "+A")
0040Reference_Author = "Not Found"
0041If Not IsNumeric(Calling_ID) Then
0042 qryString = "SELECT Authors.Author_ID FROM Authors WHERE Authors.Author_Name=""" & Calling_ID & """;"
0043 Set rsTableToRead = CurrentDb.OpenRecordset(qryString)
0044 If Not rsTableToRead.EOF Then
0045 Calling_ID_Local = rsTableToRead.Fields(0)
0046 Else
0047 Calling_ID_Local = 0
0048 End If
0049Else
0050 Calling_ID_Local = Calling_ID
0051End If
0052Do While x > 0
0053 Reference_Author = "Found"
0054 Y = InStr(x + 1, strText_Local, "A+")
0055 'Watch out for false positives in finding +A
0056 If Y = 0 Then
0057 x = x + 1
0058 Else
0059 If Y - x > 50 Then
0060 x = x + 1
0061 Else
0062 AuthorRef = Mid(strText_Local, x + 2, Y - x - 2) & ""
0063 If AuthorRef = "" Then
0064 x = x + 1
0065 Else
0066 If Left(AuthorRef, 1) = "," Then
0067 AuthorRef = Mid(AuthorRef, 2)
0068 Author_Comma = True
0069 Else
0070 Author_Comma = False
0071 End If
0072 If Y > Len(strText_Local) - 2 Then
0073 strText_End = ""
0074 Else
0075 strText_End = Mid(strText_Local, Y + 2, Len(strText_Local))
0076 End If
0077 If Calling_Type <> "X" Then
0078 qryString = "SELECT Authors.Author_ID FROM Authors WHERE Authors.Author_Name=""" & AuthorRef & """;"
0079 Set rsTableToRead = CurrentDb.OpenRecordset(qryString)
0080 If Not rsTableToRead.EOF Then
0081 Author_ID = rsTableToRead.Fields(0)
0082 Else
0083 Author_ID = 0
0084 End If
0085 OK = Cross_Reference_Add(Calling_Type, Calling_ID_Local, Calling_Timestamp, "A", Author_ID, 0)
0086 End If
0087 'Determine Author(s) & Add link
0088 AuthorLink = ""
0089 qryString = "SELECT Authors.Author_Name, Authors.Author_Name_Display FROM Authors WHERE (((Authors.Author_Name) = """ & AuthorRef & """)) Or (((Authors.Author_Name) Like """ & AuthorRef & " *"")) ORDER BY Authors.Author_Name;"
0090 Set rsTableToRead = CurrentDb.OpenRecordset(qryString)
0091 If Not rsTableToRead.EOF Then
0092 rsTableToRead.MoveFirst
0093 AuthorDirectory = Left(AuthorRef, 1)
0094 AuthorLink = rsTableToRead.Fields(0).Value
0095 If Author_Comma = True Then
0096 AuthorDisplay = Replace(AuthorLink, " (", ", ")
0097 AuthorDisplay = Replace(AuthorDisplay, ")", "")
0098 Else
0099 AuthorDisplay = rsTableToRead.Fields(1).Value & ""
0100 If AuthorDisplay = "" Then
0101 AuthorDisplay = AuthorRef
0102 End If
0103 End If
0104 AuthorLink = "<A HREF = """ & strPrefix & "Authors/" & AuthorDirectory & "/Author_" & AuthorLink & ".htm"">" & AuthorDisplay & "</A>"
0105 If Calling_Type <> "X" Then
0106 strName = "<a name=""A" & Author_ID & "_" & OK & """></a>"
0107 AuthorLink = strName & AuthorLink
0108 End If
0109 strText_Local = Left(strText_Local, x - 1) & AuthorLink & strText_End
0110 Else
0111 AuthorLink = """Unknown Author"""
0112 Author_Reformat = AuthorRef
0113 j = InStr(Author_Reformat, "(")
0114 If j > 0 Then
0115 k = InStr(j, Author_Reformat, ")")
0116 If k > 0 Then
0117 Author_Reformat = Mid(Author_Reformat, j + 1, k - j - 1) & " " & Trim(Left(Author_Reformat, j - 1))
0118 End If
0119 End If
0120 strText_Local = Left(strText_Local, x - 1) & Author_Reformat & strText_End
0121 End If
0122 Set rsTableToRead = Nothing
0123 End If
0124 End If
0125 End If
0126 x = InStr(x, strText_Local, "+A")
0127Loop
0128strText = strText_Local
0129End Function

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


Source Code of: Reference_Code
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 72
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Reference_Code(strText, Optional Depth, Optional NoText)
0002Dim x As Long
0003Dim Y As Long
0004Dim strCodeRef As String
0005Dim CodeRef As String
0006Dim strText_Local As String
0007Dim strText_End As String
0008Dim qryString As String
0009Dim rsTableToRead As Recordset
0010Dim CodeLocation As String
0011Dim iDepth As Integer
0012Dim strPrefix As String
0013Dim i As Integer
0014If Len(strText) = 0 Then
0015 Reference_Code = "Not Found"
0016 Exit Function
0017End If
0018If IsMissing(Depth) Then
0019 iDepth = 2
0020Else
0021 iDepth = Depth
0022End If
0023i = 0
0024strPrefix = ""
0025Do While i < iDepth
0026 strPrefix = strPrefix & "../"
0027 i = i + 1
0028Loop
0029strText_Local = strText
0030x = 1
0031x = InStr(x, strText_Local, "+C")
0032Reference_Code = "Not Found"
0033Do While x > 0
0034 Reference_Code = "Found"
0035 Y = InStr(x + 1, strText_Local, "C+")
0036 'Watch out for false positives in finding +C
0037 If Y = 0 Then
0038 x = x + 1
0039 Else
0040 If Y - x > 100 Then
0041 x = x + 1
0042 Else
0043 strCodeRef = Mid(strText_Local, x + 2, Y - x - 2)
0044 CodeRef = Trim(strCodeRef)
0045 If Y > Len(strText_Local) - 2 Then
0046 strText_End = ""
0047 Else
0048 strText_End = Mid(strText_Local, Y + 2, Len(strText_Local))
0049 End If
0050 'Determine Code Location
0051 CodeLocation = ""
0052 qryString = "SELECT Code_Table.Procedure_Name, Code_Table.Code_Location FROM Code_Table WHERE (((Code_Table.Procedure_Name)=""" & CodeRef & """));"
0053 Set rsTableToRead = CurrentDb.OpenRecordset(qryString)
0054 If Not rsTableToRead.EOF Then
0055 rsTableToRead.MoveFirst
0056 CodeLocation = rsTableToRead.Fields(1).Value
0057 strCodeRef = CodeRef
0058 If Not IsMissing(NoText) Then
0059 strCodeRef = "Code"
0060 End If
0061 strText_Local = Left(strText_Local, x - 1) & "<A HREF = """ & strPrefix & "Documentation/Documentation_Code_" & CodeLocation & ".htm#" & CodeRef & """>" & strCodeRef & "</A>" & strText_End
0062 Else
0063 'strText_Local = Left(strText_Local, x - 1) & CodeRef & strText_End 'This removed the +CC+ wrapper, and so made Reference_Code_Bridge fail to refer!
0064 x = x + 2
0065 End If
0066 Set rsTableToRead = Nothing
0067 End If
0068 End If
0069 x = InStr(x, strText_Local, "+C")
0070Loop
0071strText = strText_Local
0072End Function

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


Source Code of: Reference_Reference
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 34
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Reference_Reference(strText)
0002Dim x As Long
0003Dim Y As Long
0004Dim RefRef As String
0005Dim strText_Local As String
0006Dim strText_End As String
0007If Len(strText) = 0 Then
0008 Reference_Reference = "Not Found"
0009 Exit Function
0010End If
0011strText_Local = strText
0012x = 1
0013x = InStr(x, strText_Local, "+R")
0014Reference_Reference = "Not Found"
0015Do While x > 0
0016 Reference_Reference = "Found"
0017 Y = InStr(x + 1, strText_Local, "R+")
0018 If Y > 0 And (Y - x) < 50 Then 'Watch out for false references!
0019 RefRef = Mid(strText_Local, x + 2, Y - x - 2) & ""
0020 If RefRef <> "" Then
0021 If Y > Len(strText_Local) - 2 Then
0022 strText_End = ""
0023 Else
0024 strText_End = Mid(strText_Local, Y + 2, Len(strText_Local))
0025 End If
0026 'Format the reference
0027 strText_Local = Left(strText_Local, x - 1) & "<a name=""Off-Page_Link_" & RefRef & """></a>" & strText_End
0028 End If
0029 End If
0030 x = x + 1
0031 x = InStr(x, strText_Local, "+R")
0032Loop
0033strText = strText_Local
0034End Function

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


Source Code of: Spider_Copy
Procedure Type: Public Sub
Module: Spider
Lines of Code: 138
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Spider_Copy()
0002Dim iOld_Errors As Long
0003Dim iNew_Errors As Long
0004Dim rs As Recordset
0005Dim strQuery As String
0006Dim strMessage As String
0007'Copy the Temp files to the Slave Database
0008 OK = Check_Database_Size()
0009strMessage = Now() & " - Spider_Copy: Entering Spider_Copy"
0010 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0011Debug.Print strMessage
0012Set rsSpider_Temp_Links = Nothing
0013 Compact_Repair ("C:\Theo's Files\Birkbeck\Web_Generator_Performance")
0014 OK = Check_Database_Size()
0015strMessage = Now() & " - Spider_Copy: Web_Generator_Performance initial C/R complete"
0016 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0017Debug.Print strMessage
0018DoCmd.SetWarnings (False)
0019 DoCmd.RunSQL ("INSERT INTO Raw_Links_Temp ( Directory, File_Name, Raw_Link, Link_Count, Timestamp_Logged ) SELECT Raw_Links_Temp_Temp.Directory, Raw_Links_Temp_Temp.File_Name, Raw_Links_Temp_Temp.Raw_Link, Count(Raw_Links_Temp_Temp.Raw_Link) AS CountOfRaw_Link, Now() AS Expr1 FROM Raw_Links_Temp_Temp GROUP BY Raw_Links_Temp_Temp.Directory, Raw_Links_Temp_Temp.File_Name, Raw_Links_Temp_Temp.Raw_Link, Now();")
0020 DoCmd.RunSQL ("DELETE * FROM Raw_Links_Temp_Temp;")
0021 Compact_Repair ("C:\Theo's Files\Birkbeck\Web_Generator_Performance")
0022 DoCmd.RunSQL ("UPDATE Raw_Links_Temp SET Raw_Links_Temp.Link_Type = Link_Type([Raw_Links_Temp]![Raw_Link]);")
0023 OK = Check_Database_Size()
0024 strMessage = Now() & " - Spider_Copy: Raw_Links_Temp Created"
0025 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0026Debug.Print strMessage
0027'Update & Tidy Up any no-longer-existent items in Directory_Structure, ...
0028 DoCmd.OpenQuery ("Directory_Structure_Prune") 'Note: Directory_Structure_Prune might be invalid as it stands - sub-directories of "do not parse" directories could be deleted - need to check.
0029 DoCmd.OpenQuery ("Directory_Structure_Add")
0030 DoCmd.OpenQuery ("Directory_Structure_Updt")
0031 DoCmd.RunSQL ("DELETE Directory_Structure_Temp.* FROM Directory_Structure_Temp;")
0032 strQuery = "INSERT INTO Directory_Structure_Temp ( Directory, Directory_Short, Directory_Level, Timestamp_Logged, Do_Not_Parse, Updates_Only ) SELECT [Directory] & ""\"" AS Expr1, Directory_Structure.Directory_Short, Directory_Structure.Directory_Level, Directory_Structure.Timestamp_Logged, Directory_Structure.Do_Not_Parse, Directory_Structure.Updates_Only FROM Directory_Structure;"
0033DoCmd.RunSQL (strQuery)
0034 OK = Check_Database_Size()
0035 strMessage = Now() & " - Spider_Copy: Directory_Structure_Temp Created"
0036 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0037Debug.Print strMessage
0038'... Site_Map, ...
0039 DoCmd.OpenQuery ("Site_Map_Add")
0040 DoCmd.OpenQuery ("Site_Map_Updt")
0041'... the following query may be invalid if
0042 strQuery = "DELETE Site_Map.*, Directory_Structure_Temp.Directory FROM Site_Map LEFT JOIN Directory_Structure_Temp ON Site_Map.Directory = Directory_Structure_Temp.Directory WHERE (((Directory_Structure_Temp.Directory) Is Null));"
0043DoCmd.RunSQL (strQuery)
0044 OK = Check_Database_Size()
0045 strMessage = Now() & " - Spider_Copy: Site_Map Updated"
0046 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0047Debug.Print strMessage
0048'... and Raw_Links
0049 DoCmd.OpenQuery ("Raw_Links_Zap") 'Delete for processed Site_Map Files
0050'Need to compact and repair here ... slave database will be virtually empty after this
0051 Compact_Repair ("C:\Theo's Files\Birkbeck\Web_Generator_Performance")
0052 OK = Check_Database_Size()
0053 strMessage = Now() & " - Spider_Copy: Raw_Links Update Started"
0054 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0055Debug.Print strMessage
0056 DoCmd.OpenQuery ("Raw_Links_Add") 'Adds them back, and any new ones, and does the updates
0057 DoCmd.OpenQuery ("Raw_Links_Updt") 'Probably not required!
0058'Need to delete Raw_Links associateed with Site_Map Files that no longer exist
0059 DoCmd.RunSQL ("DELETE Raw_Links_Temp.* FROM Raw_Links_Temp;")
0060 DoCmd.OpenQuery ("Raw_Links_Zapper_GEN") 'Add Raw Links to be deleted to Raw_Links_Temp
0061 strQuery = "DELETE Raw_Links.* FROM Raw_Links INNER JOIN Raw_Links_Temp ON (Raw_Links.Raw_Link = Raw_Links_Temp.Raw_Link) AND (Raw_Links.File_Name = Raw_Links_Temp.File_Name) AND (Raw_Links.Directory = Raw_Links_Temp.Directory);"
0062DoCmd.RunSQL (strQuery)
0063 OK = Check_Database_Size()
0064 strMessage = Now() & " - Spider_Copy: Raw_Links Update Completed"
0065 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0066Debug.Print strMessage
0067'Tidy up Temp tables
0068 DoCmd.RunSQL ("DELETE Directory_Structure_Temp.* FROM Directory_Structure_Temp;")
0069 DoCmd.RunSQL ("DELETE Site_Map_Temp.* FROM Site_Map_Temp;")
0070 DoCmd.RunSQL ("DELETE Raw_Links_Temp.* FROM Raw_Links_Temp;")
0071 Compact_Repair ("C:\Theo's Files\Birkbeck\Web_Generator_Performance")
0072'Maintain Directory_Fine_Structure
0073 Directory_Fine_Structure_Gen
0074 OK = Check_Database_Size()
0075 strMessage = Now() & " - Spider_Copy: Directory_Fine_Structure_Gen Complete"
0076 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0077Debug.Print strMessage
0078'Determine the full links - Note - if this is run for a complete refresh, the slave database will exceed the 2Gb limit
0079' ... and will need to be Compacted&Repaired - currently every 200k records
0080 OK = Check_Database_Size()
0081 strMessage = Now() & " - Spider_Copy: Full_Link_Same_Directory_Gen Commenced"
0082 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0083Debug.Print strMessage
0084 Full_Link_Same_Directory_Gen
0085 OK = Check_Database_Size()
0086 strMessage = Now() & " - Spider_Copy: Full_Link_Same_Directory_Gen Completed"
0087 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0088Debug.Print strMessage
0089 Compact_Repair ("C:\Theo's Files\Birkbeck\Web_Generator_Performance")
0090Debug.Print Now() & " - Spider_Copy: Full_Link_Up_Levels_Gen Started"
0091 Full_Link_Up_Levels_Gen
0092 OK = Check_Database_Size()
0093 strMessage = Now() & " - Spider_Copy: Full_Link_Up_Levels_Gen Complete"
0094 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0095Debug.Print strMessage
0096 Compact_Repair ("C:\Theo's Files\Birkbeck\Web_Generator_Performance")
0097 Full_Link_Sections_Fix
0098 OK = Check_Database_Size()
0099 strMessage = Now() & " - Spider_Copy: Full_Link_Sections_Fix Complete"
0100 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0101Debug.Print strMessage
0102 Compact_Repair ("C:\Theo's Files\Birkbeck\Web_Generator_Performance")
0103'Update the "missing links" table
0104 DoCmd.OpenQuery ("Raw_Broken_Links_Old_Zap")
0105 DoCmd.OpenQuery ("Raw_Broken_Links_Old_Updt") 'Save a copy of the broken links table
0106 DoCmd.OpenQuery ("Raw_Broken_Links_Old_Counts_Detail") 'Display an error summary
0107 DoCmd.OpenQuery ("Raw_Broken_Links_Zap")
0108 DoCmd.OpenQuery ("Spider_Missing_Internal_Links_Add") 'Add broken links to Raw_Broken_Links table
0109 DoCmd.OpenQuery ("Raw_Broken_Links_Error_Reference_Copy") 'Copy Error_References from Raw_Broken_Links_Old table to Raw_Broken_Links table
0110 DoCmd.OpenQuery ("Raw_Links_Error_References_Clear") 'Clear Error_References in Raw_Links table in case they've been fixed
0111 DoCmd.OpenQuery ("Raw_Links_Error_References_Updt") 'Copy unfixed Error_References from Raw_Broken_Links back to Raw_Links
0112 DoCmd.OpenQuery ("Raw_Broken_Links_Detail_List") 'Display an error list
0113 DoCmd.OpenQuery ("Raw_Broken_Links_Counts_Detail") 'Display an error summary
0114 DoCmd.OpenQuery ("Raw_Broken_Links_Fixed_Counts") 'Display a summary of fixed errors
0115 Set rs = CurrentDb.OpenRecordset("Raw_Broken_Links_Counts")
0116If Not rs.EOF Then
0117 rs.MoveFirst
0118 If rs.Fields(0).Value = "1. Old" Then
0119 iOld_Errors = rs.Fields(1).Value
0120 Else
0121 iOld_Errors = 0
0122 End If
0123 DoEvents
0124 rs.MoveLast
0125 If rs.Fields(0).Value = "2. New" Then
0126 iNew_Errors = rs.Fields(1).Value
0127 Else
0128 iNew_Errors = 0
0129 End If
0130 DoEvents
0131End If
0132Set rs = Nothing
0133 OK = Check_Database_Size()
0134strMessage = Now() & " - Spider_Copy: New Broken Links = " & iNew_Errors & "; Old Broken Links Carried Forward = " & iOld_Errors
0135 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0136Debug.Print strMessage
0137DoCmd.SetWarnings (True)
0138End Sub

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


© Theo Todman, June 2007 - Sept 2023. 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