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: 128
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 iDepth As Integer
0012Dim strPrefix As String
0013Dim i As Integer
0014Dim Calling_ID_Local As Integer
0015Dim Author_ID As Integer
0016Dim AuthorDisplay As String
0017Dim Author_Comma As Boolean
0018Dim Author_Reformat As String
0019Dim j As Integer
0020Dim k As Integer
0021If Len(strText) = 0 Then
0022 Reference_Author = "Not Found"
0023 Exit Function
0024End If
0025If IsMissing(Depth) Then
0026 iDepth = 2
0027Else
0028 iDepth = Depth
0029End If
0030i = 0
0031strPrefix = ""
0032Do While i < iDepth
0033 strPrefix = strPrefix & "../"
0034 i = i + 1
0035Loop
0036strText_Local = strText
0037x = 1
0038x = InStr(x, strText_Local, "+A")
0039Reference_Author = "Not Found"
0040If Not IsNumeric(Calling_ID) Then
0041 qryString = "SELECT Authors.Author_ID FROM Authors WHERE Authors.Author_Name=""" & Calling_ID & """;"
0042 Set rsTableToRead = CurrentDb.OpenRecordset(qryString)
0043 If Not rsTableToRead.EOF Then
0044 Calling_ID_Local = rsTableToRead.Fields(0)
0045 Else
0046 Calling_ID_Local = 0
0047 End If
0048Else
0049 Calling_ID_Local = Calling_ID
0050End If
0051Do While x > 0
0052 Reference_Author = "Found"
0053 Y = InStr(x + 1, strText_Local, "A+")
0054 'Watch out for false positives in finding +A
0055 If Y = 0 Then
0056 x = x + 1
0057 Else
0058 If Y - x > 50 Then
0059 x = x + 1
0060 Else
0061 AuthorRef = Mid(strText_Local, x + 2, Y - x - 2) & ""
0062 If AuthorRef = "" Then
0063 x = x + 1
0064 Else
0065 If Left(AuthorRef, 1) = "," Then
0066 AuthorRef = Mid(AuthorRef, 2)
0067 Author_Comma = True
0068 Else
0069 Author_Comma = False
0070 End If
0071 If Y > Len(strText_Local) - 2 Then
0072 strText_End = ""
0073 Else
0074 strText_End = Mid(strText_Local, Y + 2, Len(strText_Local))
0075 End If
0076 'Determine Author(s)
0077 AuthorLink = ""
0078 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;"
0079 Set rsTableToRead = CurrentDb.OpenRecordset(qryString)
0080 If Not rsTableToRead.EOF Then
0081 rsTableToRead.MoveFirst
0082 AuthorDirectory = Left(AuthorRef, 1)
0083 AuthorLink = rsTableToRead.Fields(0).Value
0084 If Author_Comma = True Then
0085 AuthorDisplay = Replace(AuthorLink, " (", ", ")
0086 AuthorDisplay = Replace(AuthorDisplay, ")", "")
0087 Else
0088 AuthorDisplay = rsTableToRead.Fields(1).Value & ""
0089 If AuthorDisplay = "" Then
0090 AuthorDisplay = AuthorRef
0091 End If
0092 End If
0093 AuthorLink = "<A HREF = """ & strPrefix & "Authors/" & AuthorDirectory & "/Author_" & AuthorLink & ".htm"">" & AuthorDisplay & "</A>"
0094 If Calling_Type <> "X" Then
0095 AuthorLink = "<a name=""" & NameRef + 1 & """></a>" & AuthorLink
0096 End If
0097 strText_Local = Left(strText_Local, x - 1) & AuthorLink & strText_End
0098 Else
0099 AuthorLink = """Unknown Author"""
0100 Author_Reformat = AuthorRef
0101 j = InStr(Author_Reformat, "(")
0102 If j > 0 Then
0103 k = InStr(j, Author_Reformat, ")")
0104 If k > 0 Then
0105 Author_Reformat = Mid(Author_Reformat, j + 1, k - j - 1) & " " & Trim(Left(Author_Reformat, j - 1))
0106 End If
0107 End If
0108 strText_Local = Left(strText_Local, x - 1) & Author_Reformat & strText_End
0109 End If
0110 If Calling_Type <> "X" Then
0111 qryString = "SELECT Authors.Author_ID FROM Authors WHERE Authors.Author_Name=""" & AuthorRef & """;"
0112 Set rsTableToRead = CurrentDb.OpenRecordset(qryString)
0113 If Not rsTableToRead.EOF Then
0114 Author_ID = rsTableToRead.Fields(0)
0115 Else
0116 Author_ID = 0
0117 End If
0118 NameRef = NameRef + 1
0119 OK = Cross_Reference_Add(Calling_Type, Calling_ID_Local, Calling_Timestamp, "A", Author_ID, 0)
0120 End If
0121 Set rsTableToRead = Nothing
0122 End If
0123 End If
0124 End If
0125 x = InStr(x, strText_Local, "+A")
0126Loop
0127strText = strText_Local
0128End 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) < 30 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: 132
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
0012DoCmd.SetWarnings (False)
0013 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();")
0014Set rsSpider_Temp_Links = Nothing
0015 DoCmd.RunSQL ("DELETE * FROM Raw_Links_Temp_Temp;")
0016 Compact_Repair ("C:\Theo's Files\Birkbeck\Web_Generator_Performance")
0017 DoCmd.RunSQL ("UPDATE Raw_Links_Temp SET Raw_Links_Temp.Link_Type = Link_Type([Raw_Links_Temp]![Raw_Link]);")
0018 OK = Check_Database_Size()
0019 strMessage = Now() & " - Spider_Copy: Raw_Links_Temp Created"
0020 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0021Debug.Print strMessage
0022'Update & Tidy Up any no-longer-existent items in Directory_Structure, ...
0023 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.
0024 DoCmd.OpenQuery ("Directory_Structure_Add")
0025 DoCmd.OpenQuery ("Directory_Structure_Updt")
0026 DoCmd.RunSQL ("DELETE Directory_Structure_Temp.* FROM Directory_Structure_Temp;")
0027 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;"
0028DoCmd.RunSQL (strQuery)
0029 OK = Check_Database_Size()
0030 strMessage = Now() & " - Spider_Copy: Directory_Structure_Temp Created"
0031 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0032Debug.Print strMessage
0033'... Site_Map, ...
0034 DoCmd.OpenQuery ("Site_Map_Add")
0035 DoCmd.OpenQuery ("Site_Map_Updt")
0036'... the following query may be invalid if
0037 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));"
0038DoCmd.RunSQL (strQuery)
0039 OK = Check_Database_Size()
0040 strMessage = Now() & " - Spider_Copy: Site_Map Updated"
0041 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0042Debug.Print strMessage
0043'... and Raw_Links
0044 DoCmd.OpenQuery ("Raw_Links_Zap") 'Delete for processed Site_Map Files
0045'Need to compact and repair here ... slave database will be virtually empty after this
0046 Compact_Repair ("C:\Theo's Files\Birkbeck\Web_Generator_Performance")
0047 OK = Check_Database_Size()
0048 strMessage = Now() & " - Spider_Copy: Raw_Links Update Started"
0049 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0050Debug.Print strMessage
0051 DoCmd.OpenQuery ("Raw_Links_Add") 'Adds them back, and any new ones, and does the updates
0052 DoCmd.OpenQuery ("Raw_Links_Updt") 'Probably not required!
0053'Need to delete Raw_Links associateed with Site_Map Files that no longer exist
0054 DoCmd.RunSQL ("DELETE Raw_Links_Temp.* FROM Raw_Links_Temp;")
0055 DoCmd.OpenQuery ("Raw_Links_Zapper_GEN") 'Add Raw Links to be deleted to Raw_Links_Temp
0056 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);"
0057DoCmd.RunSQL (strQuery)
0058 OK = Check_Database_Size()
0059 strMessage = Now() & " - Spider_Copy: Raw_Links Update Completed"
0060 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0061Debug.Print strMessage
0062'Tidy up Temp tables
0063 DoCmd.RunSQL ("DELETE Directory_Structure_Temp.* FROM Directory_Structure_Temp;")
0064 DoCmd.RunSQL ("DELETE Site_Map_Temp.* FROM Site_Map_Temp;")
0065 DoCmd.RunSQL ("DELETE Raw_Links_Temp.* FROM Raw_Links_Temp;")
0066 Compact_Repair ("C:\Theo's Files\Birkbeck\Web_Generator_Performance")
0067'Maintain Directory_Fine_Structure
0068 Directory_Fine_Structure_Gen
0069 OK = Check_Database_Size()
0070 strMessage = Now() & " - Spider_Copy: Directory_Fine_Structure_Gen Complete"
0071 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0072Debug.Print strMessage
0073'Determine the full links - Note - if this is run for a complete refresh, the slave database will exceed the 2Gb limit
0074' ... and will need to be Compacted&Repaired - currently every 200k records
0075 OK = Check_Database_Size()
0076 strMessage = Now() & " - Spider_Copy: Full_Link_Same_Directory_Gen Commenced"
0077 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0078Debug.Print strMessage
0079 Full_Link_Same_Directory_Gen
0080 OK = Check_Database_Size()
0081 strMessage = Now() & " - Spider_Copy: Full_Link_Same_Directory_Gen Completed"
0082 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0083Debug.Print strMessage
0084 Compact_Repair ("C:\Theo's Files\Birkbeck\Web_Generator_Performance")
0085Debug.Print Now() & " - Spider_Copy: Full_Link_Up_Levels_Gen Started"
0086 Full_Link_Up_Levels_Gen
0087 OK = Check_Database_Size()
0088 strMessage = Now() & " - Spider_Copy: Full_Link_Up_Levels_Gen Complete"
0089 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0090Debug.Print strMessage
0091 Compact_Repair ("C:\Theo's Files\Birkbeck\Web_Generator_Performance")
0092 Full_Link_Sections_Fix
0093 OK = Check_Database_Size()
0094 strMessage = Now() & " - Spider_Copy: Full_Link_Sections_Fix Complete"
0095 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0096Debug.Print strMessage
0097 Compact_Repair ("C:\Theo's Files\Birkbeck\Web_Generator_Performance")
0098'Update the "missing links" table
0099 DoCmd.OpenQuery ("Raw_Broken_Links_Old_Zap")
0100 DoCmd.OpenQuery ("Raw_Broken_Links_Old_Updt") 'Save a copy of the broken links table
0101 DoCmd.OpenQuery ("Raw_Broken_Links_Old_Counts_Detail") 'Display an error summary
0102 DoCmd.OpenQuery ("Raw_Broken_Links_Zap")
0103 DoCmd.OpenQuery ("Spider_Missing_Internal_Links_Add") 'Add broken links to Raw_Broken_Links table
0104 DoCmd.OpenQuery ("Raw_Broken_Links_Error_Reference_Copy") 'Copy Error_References from Raw_Broken_Links_Old table to Raw_Broken_Links table
0105 DoCmd.OpenQuery ("Raw_Links_Error_References_Clear") 'Clear Error_References in Raw_Links table in case they've been fixed
0106 DoCmd.OpenQuery ("Raw_Links_Error_References_Updt") 'Copy unfixed Error_References from Raw_Broken_Links back to Raw_Links
0107 DoCmd.OpenQuery ("Raw_Broken_Links_Counts_Detail") 'Display an error summary
0108 DoCmd.OpenQuery ("Raw_Broken_Links_Fixed_Counts") 'Display a summary of fixed errors
0109 Set rs = CurrentDb.OpenRecordset("Raw_Broken_Links_Counts")
0110If Not rs.EOF Then
0111 rs.MoveFirst
0112 If rs.Fields(0).Value = "1. Old" Then
0113 iOld_Errors = rs.Fields(1).Value
0114 Else
0115 iOld_Errors = 0
0116 End If
0117 DoEvents
0118 rs.MoveLast
0119 If rs.Fields(0).Value = "2. New" Then
0120 iNew_Errors = rs.Fields(1).Value
0121 Else
0122 iNew_Errors = 0
0123 End If
0124 DoEvents
0125End If
0126Set rs = Nothing
0127 OK = Check_Database_Size()
0128strMessage = Now() & " - Spider_Copy: New Broken Links = " & iNew_Errors & "; Old Broken Links Carried Forward = " & iOld_Errors
0129 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0130Debug.Print strMessage
0131DoCmd.SetWarnings (True)
0132End 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 - Oct 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