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 17 (12 items)

cmdBooksMove_ClickcmdVisitorStats_ClickCopyReplace_TextStream_FixCopyReplace_TextStreamPrint
Find_NoteID_PrintFind_StrReplaceNoteLink_FixArchive_Regen
Historical_Note_Book_LinksHistorical_Note_Paper_LinksNotes_Move_Fix_ControlQuery_Name_Fragments_GEN

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

Go to top of page



Source Code of: Archive_Regen
Procedure Type: Public Sub
Module: Testing
Lines of Code: 6

Line-No. / Ref.Code Line
0001Public Sub Archive_Regen()
0002'Add changed procedures
0003 DoCmd.RunSQL ("INSERT INTO Code_Archive_Table ( Procedure_Name, Archive_Date, Procedure_Type, [Module], Code, Lines, ID, Code_Location, [Parameters] ) SELECT Code_Table_Old.Procedure_Name, #" & "01 January 2016" & "# AS [Date], Code_Table_Old.Procedure_Type, Code_Table_Old.Module, Code_Table_Old.Code, Code_Table_Old.Lines, Code_Table_Old.ID, Code_Table_Old.Code_Location, Code_Table_Old.Parameters FROM Code_Table_Old;")
0004'Delete archives that are duplicates
0005 Code_Archive_Prune
0006End Sub

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


Source Code of: cmdBooksMove_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 12

Line-No. / Ref.Code Line
0001Private Sub cmdBooksMove_Click()
0002'Update Stats
0003 DoCmd.OpenQuery ("Book_Location_Stats_Temp_Zap")
0004 DoCmd.OpenQuery ("Book_Location_Stats_Temp_GEN")
0005 DoCmd.OpenQuery ("Locations_Stats_Zap")
0006 DoCmd.OpenQuery ("Locations_Stats_Update")
0007 DoCmd.OpenQuery ("BookSummaryCountCostLocation")
0008 DoCmd.OpenQuery ("Books - Move")
0009 DoCmd.OpenTable ("Locations")
0010 DoCmd.OpenQuery ("Book_Paper_Filing")
0011 DoCmd.OpenQuery ("Authors_List_Fix")
0012End Sub

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


Source Code of: cmdVisitorStats_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 15

Line-No. / Ref.Code Line
0001Private Sub cmdVisitorStats_Click()
0002Dim start As Date
0003Dim Duration As Single
0004If MsgBox("Have you new Stats to import? Place the files in ""C:\Theo's Files\Websites\Visitor_Stats""", vbYesNo) = vbYes Then
0005 Stop
0006 start = Now()
0007 Page_Hits_Import_Control
0008Else
0009 start = Now()
0010End If
0011 Page_Hits_Page_Gen (1)
0012 Page_Hits_Page_Gen (2)
0013Duration = Round((Now() - start) * 24 * 60 * 60, 2)
0014MsgBox Now() & " - Visitor Stats Reporting Completed in " & Duration & " seconds. ", vbOKOnly, "Test"
0015End Sub

Procedures Called By This Procedure (cmdVisitorStats_Click) Go To Top of This Page
Link to VBA Code Control Page


Source Code of: CopyReplace_TextStream_Fix
Procedure Type: Public Function
Module: Notes_Move_Fix
Lines of Code: 31
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function CopyReplace_TextStream_Fix(InFile, OutFile, NoteSubDirectory)
0002'This is a new module to read the html files and update the Notes directories
0003'It was based on http://www.tutorial-web.com/asp/fso/textstream
0004Dim fso As FileSystemObject
0005Dim tsTextFileIn As TextStream
0006Dim tsTextFileOut As TextStream
0007Dim strLine As String
0008Dim MainFolder
0009Dim FileCollection
0010Dim File
0011Dim Updated_Flag As String
0012Set fso = CreateObject("Scripting.FileSystemObject")
0013Set tsTextFileIn = fso.OpenTextFile(InFile, 1, False, 0)
0014If Dir(OutFile) <> "" Then 'If we already have a file in the transfer directory, then zap it
0015 Kill OutFile
0016End If
0017Set tsTextFileOut = fso.CreateTextFile(OutFile, True, True)
0018Updated_Flag = "No"
0019Do Until tsTextFileIn.AtEndOfStream
0020 strLine = tsTextFileIn.ReadLine
0021 'Translate the line for Notes Links
0022 strLine = ReplaceNoteLink_Fix(strLine, """Notes_", """Notes_Print", NoteSubDirectory, Updated_Flag, InFile)
0023 tsTextFileOut.WriteLine strLine
0024Loop
0025If Updated_Flag = "No" Then 'If we haven't updated the output file, then zap it
0026 Set tsTextFileOut = Nothing
0027 Kill OutFile
0028Else
0029 Debug.Print Now() & " - "; OutFile
0030End If
0031End Function

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


Source Code of: CopyReplace_TextStreamPrint
Procedure Type: Public Function
Module: Notes_Print_Move
Lines of Code: 22
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function CopyReplace_TextStreamPrint(InFile, OutFile)
0002'This is a new module to read the html files and update the Notes directories
0003'It was based on http://www.tutorial-web.com/asp/fso/textstream
0004Dim fso As FileSystemObject
0005Dim tsTextFileIn As TextStream
0006Dim tsTextFileOut As TextStream
0007Dim strLine As String
0008Dim MainFolder
0009Dim FileCollection
0010Dim File
0011Set fso = CreateObject("Scripting.FileSystemObject")
0012Set tsTextFileIn = fso.OpenTextFile(InFile, 1, False, 0)
0013If Dir(OutFile) <> "" Then 'If we already have a file in the transfer directory, then zap it
0014 Kill OutFile
0015End If
0016Set tsTextFileOut = fso.CreateTextFile(OutFile, True, True)
0017Do Until tsTextFileIn.AtEndOfStream
0018 strLine = tsTextFileIn.ReadLine
0019 'No Translation required in Printed Notes
0020 tsTextFileOut.WriteLine strLine
0021Loop
0022End Function

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


Source Code of: Find_NoteID_Print
Procedure Type: Public Function
Module: Notes_Print_Move
Lines of Code: 28
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Find_NoteID_Print(File_Name)
0002Dim ihtm As Integer
0003Dim iNotes As Integer
0004Dim iUnderscore As Integer
0005Dim iEndNoteID As Integer
0006Dim strNoteID As String
0007Find_NoteID_Print = ""
0008'Find ".htm"
0009ihtm = InStr(1, File_Name, ".htm")
0010If ihtm = 0 Then 'Not a .htm file
0011 Exit Function
0012End If
0013'Find "NotesPrint_
0014iNotes = InStr(1, File_Name, "NotesPrint_")
0015If iNotes = 0 Then
0016 Exit Function
0017Else
0018 'Find "_" (if any)
0019 iUnderscore = InStr(iNotes + 11, File_Name, "_")
0020 If iUnderscore = 0 Then
0021 iEndNoteID = ihtm
0022 Else
0023 iEndNoteID = iUnderscore
0024 End If
0025 strNoteID = Mid(File_Name, iNotes + 11, iEndNoteID - iNotes - 11)
0026 Find_NoteID_Print = strNoteID
0027End If
0028End Function

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


Source Code of: Find_Str
Procedure Type: Public Function
Module: Historical_Links
Lines of Code: 23
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Find_Str(strLine, strOut, str1, str2, str3, str4)
0002'For finding the ID of Paper or Book Summaries links in text strings - but could presumably be used for other searches
0003'Model: PaperSummaries/PaperSummary_12/PaperSummary_12018.htm
0004Dim x As Long
0005Dim Y As Long
0006Find_Str = 0
0007strOut = ""
0008x = 1
0009x = InStr(x, strLine, str1)
0010If x > 0 Then
0011 x = InStr(x + 1, strLine, str2)
0012 If x > 0 Then
0013 x = InStr(x + 1, strLine, str3)
0014 If x > 0 Then
0015 Y = InStr(x + 1, strLine, str4)
0016 If x > 0 Then
0017 strOut = Mid(strLine, x + Len(str3), Y - x - Len(str3))
0018 Find_Str = x
0019 End If
0020 End If
0021 End If
0022End If
0023End Function

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


Source Code of: Historical_Note_Book_Links
Procedure Type: Public Sub
Module: Historical_Links
Lines of Code: 92
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Historical_Note_Book_Links()
0002Dim rst As Recordset
0003Dim rst2 As Recordset
0004Dim db As Database
0005Dim fso As FileSystemObject
0006Dim tsTextFileIn As TextStream
0007Dim strLine As String
0008Dim InFile As String
0009Dim DirectoryName As String
0010Dim MainFolder
0011Dim FileCollection
0012Dim File
0013Dim File_Name As String
0014Dim Note_ID As String
0015Dim Sub_ID As String
0016Dim Last_Section As Integer
0017Dim Next_Section As Integer
0018Dim x As Long
0019Dim z As Long
0020Dim zz As Long
0021Dim zzz As Long
0022Dim strSection As String
0023Dim strBook As String
0024Set db = CurrentDb
0025 Set rst = db.OpenRecordset("Select * FROM Note_Book_Links WHERE Note = 0;")
0026Set fso = CreateObject("Scripting.FileSystemObject")
0027strSection = "<a name=""Section_"
0028DirectoryName = TheoWebsiteRoot & "\Secure_Jen\Notes_8\"
0029Set MainFolder = fso.GetFolder(DirectoryName)
0030Set FileCollection = MainFolder.Files
0031For Each File In FileCollection
0032 File_Name = File.Name
0033 Sub_ID = ""
0034 Note_ID = Find_NoteID(File_Name, Sub_ID) 'Determine Note_ID
0035 If Note_ID = "" Then
0036 Debug.Print Now() & " - "; File_Name & ", ID not Found"
0037 Else
0038 InFile = DirectoryName & File_Name
0039 Set tsTextFileIn = fso.OpenTextFile(InFile, 1, False, 0) 'Open the file
0040 Debug.Print Now() & " - "; InFile & ", " & Note_ID & ", " & Sub_ID
0041 If Sub_ID <> "" Then 'For archived Notes only, rummage for Books
0042 Last_Section = 0
0043 Do Until tsTextFileIn.AtEndOfStream
0044 'NOTE: May need to watch out for REFERENCES & READING LIST, to avoid multiple counting
0045 'ALSO: Need to put <A NAME="xxx"> for the various sections at the end of a Note, to make hyerlinking easier
0046 x = 1
0047 zzz = 1
0048 strLine = tsTextFileIn.ReadLine
0049 z = InStr(x, strLine, strSection)
0050 Do While zzz > 0
0051 zzz = Find_Str(Mid(strLine, x, Len(strLine)), strBook, "BookSummaries/", "BookSummary_", "BookSummary_", ".htm") 'LOOK FOR BookSummaries/BookSummary_yy/BookSummary_xxxx.htm
0052 x = x + zzz
0053 If zzz > 0 And Len(strBook) < 8 Then 'If found, and not "odd"
0054 Do While z < x 'Find the next Section
0055 If z > 0 Then
0056 z = InStr(z, strLine, strSection)
0057 End If
0058 If z > 0 Then
0059 zz = InStr(z, strLine, """>")
0060 Next_Section = Mid(strLine, z + Len(strSection), zz - z - Len(strSection))
0061 Debug.Print Now() & " - "; Mid(strLine, z, 2 * Len(strSection)) & ", " & Next_Section
0062 If z < x Then
0063 Last_Section = Next_Section
0064 End If
0065 z = z + 1
0066 Else
0067 z = Len(strLine) + 1
0068 End If
0069 Loop
0070 'Write out a record
0071 '... if not already there
0072 Set rst2 = db.OpenRecordset("SELECT Note_Book_Links.Note, Note_Book_Links.Note_Ref, Note_Book_Links.Book, Note_Book_Links.Timestamp FROM Note_Book_Links WHERE (((Note_Book_Links.Note)=" & Note_ID & ") AND ((Note_Book_Links.Note_Ref)=" & Last_Section & ") AND ((Note_Book_Links.Book)=" & strBook & ") AND ((Note_Book_Links.Timestamp)=" & Sub_ID & "));")
0073 If rst2.EOF Then
0074 rst.AddNew
0075 rst.Fields(0) = Note_ID
0076 rst.Fields(1) = Last_Section 'Section ... this seems to be the notes sequence number, not the section number
0077 rst.Fields(2) = strBook
0078 rst.Fields(3) = Sub_ID
0079 rst.Update
0080 End If
0081 Set rst2 = Nothing
0082 Debug.Print Now() & " - "; strBook
0083 End If
0084 Loop
0085 Loop
0086 End If
0087 End If
0088Next
0089Set rst = Nothing
0090Set MainFolder = Nothing
0091Set FileCollection = Nothing
0092End Sub

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


Source Code of: Historical_Note_Paper_Links
Procedure Type: Public Sub
Module: Historical_Links
Lines of Code: 92
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Historical_Note_Paper_Links()
0002Dim rst As Recordset
0003Dim rst2 As Recordset
0004Dim db As Database
0005Dim fso As FileSystemObject
0006Dim tsTextFileIn As TextStream
0007Dim strLine As String
0008Dim InFile As String
0009Dim DirectoryName As String
0010Dim MainFolder
0011Dim FileCollection
0012Dim File
0013Dim File_Name As String
0014Dim Note_ID As String
0015Dim Sub_ID As String
0016Dim Last_Section As Integer
0017Dim Next_Section As Integer
0018Dim x As Long
0019Dim z As Long
0020Dim zz As Long
0021Dim zzz As Long
0022Dim strSection As String
0023Dim strPaper As String
0024Set db = CurrentDb
0025 Set rst = db.OpenRecordset("Select * FROM Note_Paper_Links WHERE Note = 0;")
0026Set fso = CreateObject("Scripting.FileSystemObject")
0027strSection = "<a name=""Section_"
0028DirectoryName = TheoWebsiteRoot & "\Secure_Jen\Notes_8\"
0029Set MainFolder = fso.GetFolder(DirectoryName)
0030Set FileCollection = MainFolder.Files
0031For Each File In FileCollection
0032 File_Name = File.Name
0033 Sub_ID = ""
0034 Note_ID = Find_NoteID(File_Name, Sub_ID) 'Determine Note_ID
0035 If Note_ID = "" Then
0036 Debug.Print Now() & " - "; File_Name & ", ID not Found"
0037 Else
0038 InFile = DirectoryName & File_Name
0039 Set tsTextFileIn = fso.OpenTextFile(InFile, 1, False, 0) 'Open the file
0040 Debug.Print Now() & " - "; InFile & ", " & Note_ID & ", " & Sub_ID
0041 If Sub_ID <> "" Then 'For archived Notes only, rummage for Papers
0042 Last_Section = 0
0043 Do Until tsTextFileIn.AtEndOfStream
0044 'NOTE: May need to watch out for REFERENCES & READING LIST, to avoid multiple counting
0045 'ALSO: Need to put <A NAME="xxx"> for the various sections at the end of a Note, to make hyerlinking easier
0046 x = 1
0047 zzz = 1
0048 strLine = tsTextFileIn.ReadLine
0049 z = InStr(x, strLine, strSection)
0050 Do While zzz > 0
0051 zzz = Find_Str(Mid(strLine, x, Len(strLine)), strPaper, "PaperSummaries/", "PaperSummary_", "PaperSummary_", ".htm") 'LOOK FOR PaperSummaries/PaperSummary_yy/PaperSummary_xxxx.htm
0052 x = x + zzz
0053 If zzz > 0 And Len(strPaper) < 8 Then 'If found, and not "odd"
0054 Do While z < x 'Find the next Section
0055 If z > 0 Then
0056 z = InStr(z, strLine, strSection)
0057 End If
0058 If z > 0 Then
0059 zz = InStr(z, strLine, """>")
0060 Next_Section = Mid(strLine, z + Len(strSection), zz - z - Len(strSection))
0061 Debug.Print Now() & " - "; Mid(strLine, z, 2 * Len(strSection)) & ", " & Next_Section
0062 If z < x Then
0063 Last_Section = Next_Section
0064 End If
0065 z = z + 1
0066 Else
0067 z = Len(strLine) + 1
0068 End If
0069 Loop
0070 'Write out a record
0071 '... if not already there
0072 Set rst2 = db.OpenRecordset("SELECT Note_Paper_Links.Note, Note_Paper_Links.Note_Ref, Note_Paper_Links.Paper, Note_Paper_Links.Timestamp FROM Note_Paper_Links WHERE (((Note_Paper_Links.Note)=" & Note_ID & ") AND ((Note_Paper_Links.Note_Ref)=" & Last_Section & ") AND ((Note_Paper_Links.Paper)=" & strPaper & ") AND ((Note_Paper_Links.Timestamp)=" & Sub_ID & "));")
0073 If rst2.EOF Then
0074 rst.AddNew
0075 rst.Fields(0) = Note_ID
0076 rst.Fields(1) = Last_Section 'Section ... this seems to be the notes sequence number, not the section number
0077 rst.Fields(2) = strPaper
0078 rst.Fields(3) = Sub_ID
0079 rst.Update
0080 End If
0081 Set rst2 = Nothing
0082 Debug.Print Now() & " - "; strPaper
0083 End If
0084 Loop
0085 Loop
0086 End If
0087 End If
0088Next
0089Set rst = Nothing
0090Set MainFolder = Nothing
0091Set FileCollection = Nothing
0092End Sub

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


Source Code of: Notes_Move_Fix_Control
Procedure Type: Public Sub
Module: Notes_Move_Fix
Lines of Code: 38
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Notes_Move_Fix_Control()
0002'This is a new module to read the html files and update the Notes directories
0003'It determines errors in the module Notes_Move_Control and fixes them
0004'Needs to run as often as required, by directory
0005Dim fso As FileSystemObject
0006Dim tsTextFileIn As TextStream
0007Dim InFile As String
0008Dim OutFile As String
0009Dim DirectoryName As String
0010Dim MainFolder
0011Dim FileCollection
0012Dim File
0013Dim File_Name As String
0014Dim Note_ID As String
0015Dim New_Directory As String
0016Dim Out_Directory As String
0017Set fso = CreateObject("Scripting.FileSystemObject")
0018DirectoryName = TheoWebsiteRoot & "\Secure_Jen\Notes_8\"
0019Out_Directory = "C:\Theo's Files\Website_Fixes\"
0020Set MainFolder = fso.GetFolder(DirectoryName)
0021Set FileCollection = MainFolder.Files
0022For Each File In FileCollection
0023 File_Name = File.Name
0024 Note_ID = Find_NoteID(File_Name) 'Determine Note_ID
0025 If Note_ID = "" Then
0026 Debug.Print Now() & " - "; "ID not Found"
0027 Else
0028 InFile = DirectoryName & File_Name
0029 Set tsTextFileIn = fso.OpenTextFile(InFile, 1, False, 0) 'Open the file
0030 New_Directory = Find_New_Directory(Note_ID) 'Determine New Folder
0031 'Convert the references in the file (copying as we go)
0032 OutFile = Out_Directory & File_Name
0033 OK = CopyReplace_TextStream_Fix(InFile, OutFile, New_Directory)
0034 Set tsTextFileIn = Nothing
0035 End If
0036Next
0037Set fso = Nothing
0038End Sub

Procedures Called By This Procedure (Notes_Move_Fix_Control) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page


Source Code of: Query_Name_Fragments_GEN
Procedure Type: Public Sub
Module: Documentation
Lines of Code: 34
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Query_Name_Fragments_GEN()
0002'This Sub tries to solve the Documentation problem of query names being constructed in Code by the addition of suffixes
0003Dim rsTableToRead As Recordset
0004Dim rsTableToWrite As Recordset
0005Dim Current_Query As String
0006Dim Previous_Query As String
0007Dim Query_Fragment As String
0008 DoCmd.RunSQL ("DELETE Query_Name_Fragments.* FROM Query_Name_Fragments;")
0009 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT Query_Name FROM Query_Definitions ORDER BY Query_Name;")
0010 Set rsTableToWrite = CurrentDb.OpenRecordset("SELECT Query_Name_Fragments.* FROM Query_Name_Fragments WHERE Query_Name = ""Zzzzzz"";")
0011rsTableToRead.MoveFirst
0012Previous_Query = "ZZZ"
0013Do While Not rsTableToRead.EOF
0014 Current_Query = rsTableToRead.Fields(0).Value
0015 If Left(Current_Query, Len(Previous_Query)) = Previous_Query Then
0016 Query_Fragment = Mid(Current_Query, Len(Previous_Query) + 1, Len(Current_Query))
0017 If Left(Query_Fragment, 1) = " " Or Left(Query_Fragment, 1) = "_" Then
0018 'Add record to Query_Name_Fragments table
0019 On Error Resume Next
0020 rsTableToWrite.AddNew
0021 rsTableToWrite.Fields(0).Value = Current_Query
0022 rsTableToWrite.Fields(1).Value = Query_Fragment
0023 rsTableToWrite.Fields(2).Value = Previous_Query
0024 rsTableToWrite.Update
0025 On Error GoTo Eek:
0026 End If
0027 End If
0028 Previous_Query = Current_Query
0029 rsTableToRead.MoveNext
0030Loop
0031Exit Sub
0032Eek:
0033MsgBox ("Error """ & Err.Description & """ (" & Err.Number & ") has occurred. ")
0034End Sub

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


Source Code of: ReplaceNoteLink_Fix
Procedure Type: Public Function
Module: Notes_Move_Fix
Lines of Code: 110
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function ReplaceNoteLink_Fix(strString, Marker, Ignore_String, NoteSubDirectory, Updated_Flag, InFile)
0002'This module adds Pre_Addition pror to Marker anywhere in strString, provided Ignore_String doesn't start in the same place as Marker
0003'The primary usage is to convert references in Notes consequent on adding an extra level of directory structure
0004Dim lenString As Long
0005Dim lenMarker As Long
0006Dim lenIgn As Long
0007Dim strTemp As String
0008Dim x As Long
0009Dim Y As Long
0010Dim z As Long
0011Dim zz As Long
0012Dim NoteID As String
0013Dim SubDir As Long
0014Dim SearchString As String
0015Dim lenSearchString As String
0016strTemp = strString
0017lenString = Len(strTemp)
0018lenMarker = Len(Marker)
0019lenIgn = Len(Ignore_String)
0020x = 1
0021Y = 1
0022'Check for inter-Notes link problems ..
0023Do While Y > 0
0024 Y = InStr(x, strTemp, Marker)
0025 If Y > 0 Then
0026 If Mid(strTemp, Y, lenIgn) = Ignore_String Then
0027 x = Y + 1
0028 Else
0029 'Check for link to Jump Table
0030 If Mid(strTemp, Y + 1, 10) = "Notes_Jump" Then
0031 strTemp = Left(strTemp, Y) & "../" & Mid(strTemp, Y + 1, Len(strTemp) + 3)
0032 Debug.Print Now() & " - "; Mid(strTemp, IIf(Y > 40, (Y - 40), 1), 80)
0033 Debug.Print Now() & " - "; "Jump Table"
0034 Updated_Flag = "Yes"
0035 Else
0036 z = InStr(Y + lenMarker, strTemp, "_") 'Archived Note
0037 zz = InStr(Y + lenMarker, strTemp, ".") 'Unarchived Note
0038 If z + zz > 0 Then
0039 If z > zz Then
0040 z = zz
0041 End If
0042 NoteID = Mid(strTemp, Y + lenMarker, z - Y - lenMarker)
0043 SubDir = Find_New_Directory(NoteID)
0044 If NoteSubDirectory <> SubDir Then
0045 'Out of patch link (Note - doesn't deal with secure vs non-secure notes)
0046 strTemp = Left(strTemp, Y) & "../Notes_" & SubDir & "/" & Mid(strTemp, Y + 1, Len(strTemp) + 3)
0047 Debug.Print Now() & " - "; Mid(strTemp, IIf(Y > 40, (Y - 40), 1), 80)
0048 Debug.Print Now() & " - "; "Out of Patch"
0049 Updated_Flag = "Yes"
0050 End If
0051 End If
0052 End If
0053 x = Y + 1
0054 End If
0055 End If
0056Loop
0057x = 1
0058Y = 1
0059SearchString = "<A HREF = """
0060lenSearchString = Len(SearchString)
0061'Check for extra-Notes link problems ..
0062Do While Y > 0
0063 Y = InStr(x, strTemp, SearchString)
0064 If Y > 0 Then
0065 'Exclude boring links
0066 If (Mid(strTemp, Y + lenSearchString, 4) = "Note") Or (Mid(strTemp, Y + lenSearchString, 1) = "#") Or (Mid(strTemp, Y + lenSearchString, 4) = "http") Or (Mid(strTemp, Y + lenSearchString, 3) = "www") Or (Mid(strTemp, Y + lenSearchString, 6) = "../../") Or (Mid(strTemp, Y + lenSearchString, 1) = " ") Or (Mid(strTemp, Y + lenSearchString, 6) = "mailto") Then
0067 Else
0068 If (Mid(strTemp, Y + lenSearchString, 2) = "..") And (Mid(strTemp, Y + lenSearchString, 23) <> "../PaperCatalogIdentity") And (Mid(strTemp, Y + lenSearchString, 8) <> "../tract") And (Mid(strTemp, Y + lenSearchString, 13) <> "../Christians") And (Mid(strTemp, Y + lenSearchString, 11) <> "../Termplan") And (Mid(strTemp, Y + lenSearchString, 14) <> "../Carthusians") And (Mid(strTemp, Y + lenSearchString, 11) <> "../Database") And (Mid(strTemp, Y + lenSearchString, 14) <> "../Parkminster") And (Mid(strTemp, Y + lenSearchString, 6) <> "../OBT") And (Mid(strTemp, Y + lenSearchString, 15) <> "../Dissertation") And (Mid(strTemp, Y + lenSearchString, 8) <> "../Locke") And (Mid(strTemp, Y + lenSearchString, 9) <> "../Bridge") And (Mid(strTemp, Y + lenSearchString, 6) <> "../EBU") And (Mid(strTemp, Y + lenSearchString, 13) <> "../Convention") Then
0069 If (Mid(strTemp, Y + lenSearchString, 9) <> "../Notes_") Then
0070 Debug.Print Now() & " - "; Mid(strTemp, IIf(Y > 40, (Y - 40), 1), 80)
0071 Debug.Print Now() & " - "; InFile & ", ../ offset ... check if sufficient"
0072 End If
0073 Else
0074 strTemp = Left(strTemp, Y + lenSearchString - 1) & "../" & Mid(strTemp, Y + lenSearchString, Len(strTemp) + 3)
0075 Debug.Print Now() & " - "; Mid(strTemp, IIf(Y > 40, (Y - 40), 1), 80)
0076 Debug.Print Now() & " - "; "Updated"
0077 Updated_Flag = "Yes"
0078 End If
0079 End If
0080 x = Y + 1
0081 End If
0082Loop
0083x = 1
0084Y = 1
0085SearchString = "<A HREF="""
0086lenSearchString = Len(SearchString)
0087'Check for extra-Notes link problems ..
0088Do While Y > 0
0089 Y = InStr(x, strTemp, SearchString)
0090 If Y > 0 Then
0091 'Exclude boring links
0092 If (Mid(strTemp, Y + lenSearchString, 4) = "Note") Or (Mid(strTemp, Y + lenSearchString, 1) = "#") Or (Mid(strTemp, Y + lenSearchString, 4) = "http") Or (Mid(strTemp, Y + lenSearchString, 3) = "www") Or (Mid(strTemp, Y + lenSearchString, 6) = "../../") Or (Mid(strTemp, Y + lenSearchString, 1) = " ") Or (Mid(strTemp, Y + lenSearchString, 6) = "mailto") Then
0093 Else
0094 If (Mid(strTemp, Y + lenSearchString, 2) = "..") And (Mid(strTemp, Y + lenSearchString, 23) <> "../PaperCatalogIdentity") And (Mid(strTemp, Y + lenSearchString, 8) <> "../tract") And (Mid(strTemp, Y + lenSearchString, 13) <> "../Christians") And (Mid(strTemp, Y + lenSearchString, 11) <> "../Termplan") And (Mid(strTemp, Y + lenSearchString, 14) <> "../Carthusians") And (Mid(strTemp, Y + lenSearchString, 11) <> "../Database") And (Mid(strTemp, Y + lenSearchString, 14) <> "../Parkminster") And (Mid(strTemp, Y + lenSearchString, 6) <> "../OBT") And (Mid(strTemp, Y + lenSearchString, 15) <> "../Dissertation") And (Mid(strTemp, Y + lenSearchString, 8) <> "../Locke") And (Mid(strTemp, Y + lenSearchString, 9) <> "../Bridge") And (Mid(strTemp, Y + lenSearchString, 6) <> "../EBU") And (Mid(strTemp, Y + lenSearchString, 13) <> "../Convention") Then
0095 If (Mid(strTemp, Y + lenSearchString, 9) <> "../Notes_") Then
0096 Debug.Print Now() & " - "; Mid(strTemp, IIf(Y > 40, (Y - 40), 1), 80)
0097 Debug.Print Now() & " - "; InFile & ", ../ offset ... check if sufficient"
0098 End If
0099 Else
0100 strTemp = Left(strTemp, Y + lenSearchString - 1) & "../" & Mid(strTemp, Y + lenSearchString, Len(strTemp) + 3)
0101 Debug.Print Now() & " - "; Mid(strTemp, IIf(Y > 40, (Y - 40), 1), 80)
0102 Debug.Print Now() & " - "; "Updated"
0103 Updated_Flag = "Yes"
0104 End If
0105 End If
0106 x = Y + 1
0107 End If
0108Loop
0109ReplaceNoteLink_Fix = strTemp
0110End Function

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


© Theo Todman, June 2007 - May 2025. Please address any comments on this page to theo@theotodman.com. File output:
Website Maintenance Dashboard
Return to Top of this Page Return to Theo Todman's Philosophy Page Return to Theo Todman's Home Page