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 16 (11 items)

CopyReplace_TextStreamFind_NoteIDFind_NoteID2ReplaceLink
ReplaceNoteLinkCreateBookCitingsWebPagesCreatePaperCitingsWebPagesForm_Concatenated_Notes_List
Notes_Move_ControlNotes_Print_Move_ControlUpdate_Note_Groups_Latest_Timestamp.

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

Go to top of page



Source Code of: CopyReplace_TextStream
Procedure Type: Public Function
Module: Notes_Move
Lines of Code: 27
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function CopyReplace_TextStream(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
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 'Translate the line for Notes Links
0020 strLine = ReplaceNoteLink(strLine, "Notes_", "Notes_Print")
0021 'Translate the line for Books Links (add an extra ../)
0022 strLine = ReplaceLink(strLine, "../BookSummaries", "../")
0023 'Translate the line for Papers Links (add an extra ../)
0024 strLine = ReplaceLink(strLine, "../PaperSummaries", "../")
0025 tsTextFileOut.WriteLine strLine
0026Loop
0027End Function

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


Source Code of: CreateBookCitingsWebPages
Procedure Type: Public Sub
Module: New Code
Lines of Code: 218
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub CreateBookCitingsWebPages(Automatic)
0002'This is a new module to generate the pages that list the Books and Papers that (via my Abstract / Comments) cite a particular Book.
0003'It was based on Sub CreateAuthorsWebPages
0004'Called by WebpageBookCitings
0005Dim fsoTextFile As FileSystemObject
0006Dim tsTextFile As TextStream
0007Dim rsTableToRead As Recordset
0008Dim rsBooks As Recordset
0009Dim rsTableControl As Recordset
0010Dim strControlQuery As String
0011Dim strLine As String
0012Dim iTableColumns As Integer
0013Dim iFieldNo As Integer
0014Dim x As Integer
0015Dim strQry As String
0016Dim i As Integer
0017Dim Book_ID As Integer
0018Dim Book_ID_Previous As Integer
0019Dim ObjectID As Integer
0020Dim strFileSuffix As String
0021Dim strFileBody As String
0022Dim StartTime As Double
0023Dim Time_Stamp As String
0024Dim strAuthors As String
0025Dim iCount As Long
0026iCount = 0
0027Dim Saved_Link_Type As String
0028Dim Saved_ObjectID As Integer
0029Dim DoneEnough As Boolean
0030Dim StrComma As String
0031Dim iExtras As Integer
0032Dim strName As String
0033Set fsoTextFile = New FileSystemObject
0034strFolder = strOutputFolder
0035StartTime = Now()
0036'Read the data for Citations of this Book
0037Set rsTableToRead = CurrentDb.OpenRecordset(strDataQuery)
0038If Not rsTableToRead.EOF Then
0039 rsTableToRead.MoveFirst
0040 iTableColumns = rsTableToRead.Fields.Count
0041 'Column 0 is the Book ID, anti-Penultimate Column is the Object ID, the Penultimate Column says whether it's a Book or a Paper; the last column is the position on the page
0042 Book_ID_Previous = 0 'There is no Book_ID 0
0043 strFileSuffix = ""
0044 strFileBody = ""
0045 Do Until rsTableToRead.EOF
0046 Book_ID = rsTableToRead.Fields(0)
0047 ObjectID = rsTableToRead.Fields(iTableColumns - 3)
0048 If Book_ID_Previous <> Book_ID Then 'New Book
0049 'Read the Book Author & Title
0050 strQry = "Select Books.Title, Books.Author from Books Where Books.ID1 = " & Book_ID & ";"
0051 Set rsBooks = CurrentDb.OpenRecordset(strQry)
0052 rsBooks.MoveFirst
0053 'Write the previous Footer (except first time)
0054 If Book_ID_Previous <> 0 Then
0055 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Footer"")) ORDER BY Website_Control.Line;"
0056 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0057 rsTableControl.MoveFirst
0058 Do While Not rsTableControl.EOF
0059 Time_Stamp = rsTableControl.Fields(0) & ""
0060 OK = Replace_Timestamp(Time_Stamp)
0061 tsTextFile.WriteLine Time_Stamp
0062 rsTableControl.MoveNext
0063 Loop
0064 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0065 iCount = iCount + 1
0066 End If
0067 Book_ID_Previous = Book_ID
0068 strFileSuffix = strOutputFileShort & "_" & Book_ID
0069 strFileBody = "BookSummary_" & Mid(100000 + Book_ID, 2, 2)
0070 'Create File
0071 Set tsTextFile = fsoTextFile.CreateTextFile(strOutputFolder & strFileBody & "\" & strFileSuffix & ".htm", True, True)
0072 'Page Header
0073 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Header"")) ORDER BY Website_Control.Line;"
0074 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0075 rsTableControl.MoveFirst
0076 Do While Not rsTableControl.EOF
0077 strLine = rsTableControl.Fields(0) & ""
0078 x = InStr(1, strLine, "**BOOK**")
0079 If x > 0 Then
0080 'Add the Book Title
0081 strLine = Left(strLine, x - 1) & "<A HREF = ""BookSummary_" & Book_ID & ".htm"">" & rsBooks.Fields(0).Value & "</a>" & Mid(strLine, x + 8, Len(strLine))
0082 End If
0083 x = InStr(1, strLine, "**AUTHOR**")
0084 If x > 0 Then
0085 'Add the Book Author
0086 strAuthors = rsBooks.Fields(1)
0087 OK = Author_Reference_String(strAuthors, 2)
0088 strLine = Left(strLine, x - 1) & strAuthors & Mid(strLine, x + 10, Len(strLine))
0089 End If
0090 tsTextFile.WriteLine strLine
0091 rsTableControl.MoveNext
0092 Loop
0093 'Read Table-Control for rows
0094 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Table_Row"")) ORDER BY Website_Control.Line;"
0095 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0096 'Table Column Headings
0097 rsTableControl.MoveFirst
0098 Do While Not rsTableControl.EOF
0099 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0100 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0101 'Note: Fields start at 0, but the first one in the query is the Book ID, and the last two are the Object ID and the page-ref
0102 If iFieldNo > 0 And iFieldNo <= iTableColumns - 3 Then
0103 If iFieldNo = 6 Then
0104 tsTextFile.WriteLine "</td><td width=""10%"" class = ""BridgeLeft""><B>Repeats ...</B></td>"
0105 Else
0106 tsTextFile.WriteLine "<B> " & rsTableToRead.Fields(iFieldNo).Name & "</B>"
0107 End If
0108 End If
0109 Else
0110 tsTextFile.WriteLine rsTableControl.Fields(0) & ""
0111 End If
0112 rsTableControl.MoveNext
0113 Loop
0114 End If
0115 'Table Row
0116 rsTableControl.MoveFirst
0117 Do While Not rsTableControl.EOF
0118 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0119 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0120 If iFieldNo > 0 And iFieldNo <= iTableColumns - 2 Then
0121 If Len(rsTableToRead.Fields(iFieldNo) & "") = 0 Then
0122 strLine = "&nbsp;"
0123 Else
0124 Select Case rsTableToRead.Fields(iFieldNo).Name
0125 Case "Title"
0126 If rsTableToRead.Fields(5).Value = "." Then 'No further information
0127 strLine = rsTableToRead.Fields(iFieldNo).Value
0128 Else
0129 If rsTableToRead.Fields(iTableColumns - 2) = "Paper" Then
0130 strLine = "<A HREF = ""../../PaperSummaries/PaperSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/PaperSummary_" & ObjectID & ".htm"">" & rsTableToRead.Fields(iFieldNo).Value & "</A>"
0131 Else
0132 strLine = "<A HREF = ""../../BookSummaries/BookSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/BookSummary_" & ObjectID & ".htm"">" & rsTableToRead.Fields(iFieldNo).Value & "</A>"
0133 End If
0134 End If
0135 Case "Further Information"
0136 strName = "B" & Book_ID & "_" & rsTableToRead.Fields(iTableColumns - 1)
0137 Saved_Link_Type = rsTableToRead.Fields(iTableColumns - 2)
0138 Saved_ObjectID = ObjectID
0139 If rsTableToRead.Fields(iFieldNo).Value = "." Then
0140 If Saved_Link_Type = "Paper" Then
0141 strLine = "<A HREF = ""../../PaperSummaries/PaperSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/PaperSummary_" & ObjectID & ".htm"">Paper</A></td><td width=""10%"" class = ""BridgeLeft"">&nbsp;</td>"
0142 Else
0143 strLine = "<A HREF = ""../../BookSummaries/BookSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/BookSummary_" & ObjectID & ".htm"">Book</A></td><td width=""10%"" class = ""BridgeLeft"">&nbsp;</td>"
0144 End If
0145 Else
0146 If Saved_Link_Type = "Paper" Then
0147 strLine = "<A HREF = ""../../Abstracts/Abstract_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/Abstract_" & ObjectID & ".htm#" & strName & """>Paper Abstract</A>"
0148 Else
0149 strLine = "<A HREF = ""../../BookSummaries/BookSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/BookPaperAbstracts/BookPaperAbstracts_" & ObjectID & ".htm#" & strName & """>Book Abstract</A>"
0150 End If
0151 strLine = strLine & rsTableToRead.Fields(iFieldNo).Value & "</td>"
0152 rsTableToRead.MoveNext
0153 DoneEnough = False
0154 If Not rsTableToRead.EOF Then
0155 strLine = strLine & "<td width=""10%"" class = ""BridgeLeft"">"
0156 StrComma = ""
0157 iExtras = 1
0158 Do Until DoneEnough = True
0159 If Saved_Link_Type = rsTableToRead.Fields(iTableColumns - 2) And ObjectID = rsTableToRead.Fields(iTableColumns - 3) And Book_ID = rsTableToRead.Fields(0) Then
0160 If Saved_Link_Type = "Paper" Then
0161 strLine = strLine & StrComma & "<A HREF = ""../../Abstracts/Abstract_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/Abstract_" & ObjectID & ".htm#" & strName & """>" & iExtras & "</A>"
0162 Else
0163 strLine = strLine & StrComma & "<A HREF = ""../../BookSummaries/BookSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/BookPaperAbstracts/BookPaperAbstracts_" & ObjectID & ".htm#" & strName & """>" & iExtras & "</A>"
0164 End If
0165 rsTableToRead.MoveNext
0166 If rsTableToRead.EOF Then
0167 DoneEnough = True
0168 rsTableToRead.MovePrevious
0169 Else
0170 StrComma = ", "
0171 iExtras = iExtras + 1
0172 End If
0173 Else
0174 DoneEnough = True
0175 rsTableToRead.MovePrevious
0176 End If
0177 Loop
0178 strLine = strLine & "</td>"
0179 Else
0180 strLine = strLine & "<td width=""10%"" class = ""BridgeLeft"">&nbsp;</td>"
0181 rsTableToRead.MovePrevious
0182 End If
0183 End If
0184 Case Else
0185 If iFieldNo = 6 Then
0186 strLine = ""
0187 Else
0188 strLine = rsTableToRead.Fields(iFieldNo)
0189 End If
0190 End Select
0191 End If
0192 strLine = ReplaceCode(strLine, Chr(13) & Chr(10), "<BR>")
0193 tsTextFile.WriteLine strLine
0194 End If
0195 Else
0196 tsTextFile.WriteLine rsTableControl.Fields(0) & ""
0197 End If
0198 rsTableControl.MoveNext
0199 Loop
0200 rsTableToRead.MoveNext
0201 Loop
0202 'Write the Last Footer
0203 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Footer"")) ORDER BY Website_Control.Line;"
0204 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0205 rsTableControl.MoveFirst
0206 Do While Not rsTableControl.EOF
0207 Time_Stamp = rsTableControl.Fields(0) & ""
0208 OK = Replace_Timestamp(Time_Stamp)
0209 tsTextFile.WriteLine Time_Stamp
0210 rsTableControl.MoveNext
0211 Loop
0212 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0213 iCount = iCount + 1
0214End If
0215If Automatic = "No" Then
0216 MsgBox strOutputFile & "Book to Citing Book / Paper Links Creation Complete, in " & Round((Now() - StartTime) * 24 * 60, 1) & " minutes. " & iCount & " pages output.", vbOKOnly, "Create Book Citation Pages"
0217End If
0218End Sub

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


Source Code of: CreatePaperCitingsWebPages
Procedure Type: Public Sub
Module: New Code
Lines of Code: 179
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub CreatePaperCitingsWebPages(Automatic)
0002'This is a new module to generate the pages that list the Books and Papers that (via my Abstract / Comments) cite a particular Paper.
0003'It was based on Sub CreateAuthorsWebPages
0004'Called by WebpagePaperCitings
0005Dim fsoTextFile As FileSystemObject
0006Dim tsTextFile As TextStream
0007Dim rsTableToRead As Recordset
0008Dim rsPapers As Recordset
0009Dim rsTableControl As Recordset
0010Dim strControlQuery As String
0011Dim strLine As String
0012Dim iTableColumns As Integer
0013Dim iFieldNo As Integer
0014Dim x As Integer
0015Dim strQry As String
0016Dim i As Integer
0017Dim Paper_ID As Integer
0018Dim Paper_ID_Previous As Integer
0019Dim ObjectID As Integer
0020Dim strFileSuffix As String
0021Dim strFileBody As String
0022Dim StartTime As Double
0023Dim Time_Stamp As String
0024Dim strAuthors As String
0025Dim strPaper As String
0026Dim iCount As Long
0027Dim strName As String
0028iCount = 0
0029Set fsoTextFile = New FileSystemObject
0030strFolder = strOutputFolder
0031StartTime = Now()
0032'Read the data for Citations of this Paper
0033Set rsTableToRead = CurrentDb.OpenRecordset(strDataQuery)
0034If Not rsTableToRead.EOF Then
0035 rsTableToRead.MoveFirst
0036 iTableColumns = rsTableToRead.Fields.Count
0037 'Column 0 is the Paper ID, Anti-Penultimate Column is the Object ID, the Penultimate Column says whether it's a Book or a Paper; the last column is the reference on the page
0038 Paper_ID_Previous = 0 'There is no Paper_ID 0
0039 strFileSuffix = ""
0040 strFileBody = ""
0041 Do Until rsTableToRead.EOF
0042 Paper_ID = rsTableToRead.Fields(0)
0043 ObjectID = rsTableToRead.Fields(iTableColumns - 3)
0044 If Paper_ID_Previous <> Paper_ID Then 'New Paper
0045 'Read the Paper Author & Title
0046 strQry = "Select Papers.Title, Papers.Author from Papers Where Papers.ID = " & Paper_ID & ";"
0047 Set rsPapers = CurrentDb.OpenRecordset(strQry)
0048 If Not rsPapers.EOF Then
0049 rsPapers.MoveFirst
0050 strAuthors = rsPapers.Fields(1)
0051 strPaper = rsPapers.Fields(0)
0052 Else
0053 strAuthors = "Unknown Author"
0054 strPaper = "Unknown Paper"
0055 End If
0056 'Write the previous Footer (except first time)
0057 If Paper_ID_Previous <> 0 Then
0058 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Footer"")) ORDER BY Website_Control.Line;"
0059 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0060 rsTableControl.MoveFirst
0061 Do While Not rsTableControl.EOF
0062 Time_Stamp = rsTableControl.Fields(0) & ""
0063 OK = Replace_Timestamp(Time_Stamp)
0064 tsTextFile.WriteLine Time_Stamp
0065 rsTableControl.MoveNext
0066 Loop
0067 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0068 iCount = iCount + 1
0069 End If
0070 Paper_ID_Previous = Paper_ID
0071 strFileSuffix = strOutputFileShort & "_" & Paper_ID
0072 strFileBody = "PaperSummary_" & Mid(100000 + Paper_ID, 2, 2)
0073 'Create File
0074 Set tsTextFile = fsoTextFile.CreateTextFile(strOutputFolder & strFileBody & "\" & strFileSuffix & ".htm", True, True)
0075 'Page Header
0076 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Header"")) ORDER BY Website_Control.Line;"
0077 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0078 rsTableControl.MoveFirst
0079 Do While Not rsTableControl.EOF
0080 strLine = rsTableControl.Fields(0) & ""
0081 x = InStr(1, strLine, "**PAPER**")
0082 If x > 0 Then
0083 'Add the Paper Title
0084 strLine = Left(strLine, x - 1) & "<A HREF = ""PaperSummary_" & Paper_ID & ".htm"">" & strPaper & "</a>" & Mid(strLine, x + 9, Len(strLine))
0085 End If
0086 x = InStr(1, strLine, "**AUTHOR**")
0087 If x > 0 Then
0088 'Add the Paper Author
0089 OK = Author_Reference_String(strAuthors, 2)
0090 strLine = Left(strLine, x - 1) & strAuthors & Mid(strLine, x + 10, Len(strLine))
0091 End If
0092 tsTextFile.WriteLine strLine
0093 rsTableControl.MoveNext
0094 Loop
0095 'Read Table-Control for rows
0096 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Table_Row"")) ORDER BY Website_Control.Line;"
0097 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0098 'Table Column Headings
0099 rsTableControl.MoveFirst
0100 Do While Not rsTableControl.EOF
0101 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0102 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0103 'Note: Fields start at 0, but the first one in the query is the Paper, and the last one is the Object ID
0104 If iFieldNo > 0 And iFieldNo <= iTableColumns - 2 Then
0105 tsTextFile.WriteLine "<B> " & rsTableToRead.Fields(iFieldNo).Name & "</B>"
0106 End If
0107 Else
0108 tsTextFile.WriteLine rsTableControl.Fields(0) & ""
0109 End If
0110 rsTableControl.MoveNext
0111 Loop
0112 End If
0113 'Table Row
0114 rsTableControl.MoveFirst
0115 Do While Not rsTableControl.EOF
0116 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0117 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0118 If iFieldNo > 0 And iFieldNo <= iTableColumns - 2 Then
0119 If Len(rsTableToRead.Fields(iFieldNo) & "") = 0 Then
0120 strLine = "&nbsp;"
0121 Else
0122 Select Case rsTableToRead.Fields(iFieldNo).Name
0123 Case "Title"
0124 If rsTableToRead.Fields(5).Value <> "." Then
0125 If rsTableToRead.Fields(iTableColumns - 2) = "Paper" Then
0126 strLine = "<A HREF = ""../../PaperSummaries/PaperSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/PaperSummary_" & ObjectID & ".htm"">" & rsTableToRead.Fields(iFieldNo) & "</A>"
0127 Else
0128 strLine = "<A HREF = ""../../BookSummaries/BookSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/BookSummary_" & ObjectID & ".htm"">" & rsTableToRead.Fields(iFieldNo) & "</A>"
0129 End If
0130 Else
0131 strLine = rsTableToRead.Fields(iFieldNo)
0132 End If
0133 Case "Further Information"
0134 If rsTableToRead.Fields(iFieldNo).Value = "." Then
0135 If rsTableToRead.Fields(iTableColumns - 2) = "Paper" Then
0136 strLine = "<A HREF = ""../../PaperSummaries/PaperSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/PaperSummary_" & ObjectID & ".htm"">Paper</A>"
0137 Else
0138 strLine = "<A HREF = ""../../BookSummaries/BookSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/BookSummary_" & ObjectID & ".htm"">Book</A>"
0139 End If
0140 Else
0141 strName = "P" & Paper_ID & "_" & rsTableToRead.Fields(iTableColumns - 1)
0142 If rsTableToRead.Fields(iTableColumns - 2) = "Paper" Then
0143 strLine = "<A HREF = ""../../Abstracts/Abstract_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/Abstract_" & ObjectID & ".htm#" & strName & """>Paper Abstract</A>"
0144 Else
0145 strLine = "<A HREF = ""../../BookSummaries/BookSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/BookPaperAbstracts/BookPaperAbstracts_" & ObjectID & ".htm#" & strName & """>Book Abstract</A>"
0146 End If
0147 strLine = strLine & rsTableToRead.Fields(iFieldNo).Value
0148 End If
0149 Case Else
0150 strLine = rsTableToRead.Fields(iFieldNo)
0151 End Select
0152 End If
0153 strLine = ReplaceCode(strLine, Chr(13) & Chr(10), "<BR>")
0154 tsTextFile.WriteLine strLine
0155 End If
0156 Else
0157 tsTextFile.WriteLine rsTableControl.Fields(0) & ""
0158 End If
0159 rsTableControl.MoveNext
0160 Loop
0161 rsTableToRead.MoveNext
0162 Loop
0163 'Write the Last Footer
0164 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Footer"")) ORDER BY Website_Control.Line;"
0165 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0166 rsTableControl.MoveFirst
0167 Do While Not rsTableControl.EOF
0168 Time_Stamp = rsTableControl.Fields(0) & ""
0169 OK = Replace_Timestamp(Time_Stamp)
0170 tsTextFile.WriteLine Time_Stamp
0171 rsTableControl.MoveNext
0172 Loop
0173 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0174 iCount = iCount + 1
0175End If
0176If Automatic = "No" Then
0177 MsgBox strOutputFile & "Paper to Citing Book / Paper Links Creation Complete, in " & Round((Now() - StartTime) * 24 * 60, 1) & " minutes. " & iCount & " pages output.", vbOKOnly, "Create Paper Citation Pages"
0178End If
0179End Sub

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


Source Code of: Find_NoteID
Procedure Type: Public Function
Module: Notes_Move
Lines of Code: 44
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Find_NoteID(File_Name, Optional Sub_ID)
0002Dim ihtm As Integer
0003Dim iNotes As Integer
0004Dim iUnderscore As Integer
0005Dim iEndNoteID As Integer
0006Dim strNoteID As String
0007Find_NoteID = ""
0008'Ignore junk ...
0009If InStr(1, File_Name, "Notes_Head") > 0 Then
0010 Exit Function
0011End If
0012If InStr(1, File_Name, "Notes_Foot") > 0 Then
0013 Exit Function
0014End If
0015 If InStr(1, File_Name, "Notes_Jump") > 0 Then
0016 Exit Function
0017End If
0018'Find ".htm"
0019ihtm = InStr(1, File_Name, ".htm")
0020If ihtm = 0 Then 'Not a .htm file
0021 Exit Function
0022End If
0023'Find "Notes_
0024iNotes = InStr(1, File_Name, "Notes_")
0025If iNotes = 0 Then
0026 Exit Function
0027Else
0028 'Find "_" (if any)
0029 iUnderscore = InStr(iNotes + 6, File_Name, "_")
0030 If iUnderscore = 0 Then
0031 iEndNoteID = ihtm
0032 Else
0033 iEndNoteID = iUnderscore
0034 End If
0035 strNoteID = Mid(File_Name, iNotes + 6, iEndNoteID - iNotes - 6)
0036 Find_NoteID = strNoteID
0037End If
0038If Not IsMissing(Sub_ID) Then
0039 If iEndNoteID = ihtm Then
0040 Else
0041 Sub_ID = Mid(File_Name, iUnderscore + 1, ihtm - iUnderscore - 1)
0042 End If
0043End If
0044End Function

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


Source Code of: Find_NoteID2
Procedure Type: Public Function
Module: Notes_Move
Lines of Code: 43
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Find_NoteID2(strString)
0002'Should try to merge this with Find_NoteID in due course!
0003Dim ihtm As Integer
0004Dim iNotes As Integer
0005Dim iUnderscore As Integer
0006Dim iEndNoteID As Integer
0007Dim strNoteID As String
0008Find_NoteID2 = ""
0009'Find ".htm"
0010ihtm = InStr(1, strString, ".htm")
0011If ihtm = 0 Then 'Not a .htm file
0012 Exit Function
0013End If
0014'Ignore junk ...
0015If InStr(1, strString, "Notes_Head") > 0 Then
0016 Exit Function
0017End If
0018If InStr(1, strString, "Notes_Foot") > 0 Then
0019 Exit Function
0020End If
0021 If InStr(1, strString, "Notes_Jump") > 0 Then
0022 Exit Function
0023End If
0024'Find "Notes_
0025iNotes = InStr(1, strString, "Notes_")
0026If iNotes = 0 Then
0027 Exit Function
0028Else
0029 'Find "_" (if any)
0030 iUnderscore = InStr(iNotes + 6, strString, "_")
0031 If iUnderscore = 0 Then
0032 iEndNoteID = ihtm
0033 Else
0034 If iUnderscore > ihtm Then
0035 iEndNoteID = ihtm
0036 Else
0037 iEndNoteID = iUnderscore
0038 End If
0039 End If
0040 strNoteID = Mid(strString, iNotes + 6, iEndNoteID - iNotes - 6)
0041 Find_NoteID2 = strNoteID
0042End If
0043End Function

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


Source Code of: Form_Concatenated_Notes_List
Procedure Type: Public Sub
Module: New Code
Lines of Code: 20

Line-No. / Ref.Code Line
0001Public Sub Form_Concatenated_Notes_List()
0002Dim rsTableControl As Recordset
0003Dim i As Integer
0004Dim prefix As String
0005 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Note_Group, Title, Latest_Note_Update, Latest_Concatenation FROM Note_Groups WHERE [Active?] = ""Yes"" ORDER BY Title;")
0006 strList = "<P><FONT Size = 2 FACE=""Arial"">See the list below for concatenated versions of all my Notes, broken down by category. The concatenation is now - on account of size - restricted to a list of properties rather than the full text. Where the list item is noted as ""out of date by n days"", this indicates that at least one of the associated Notes has been updated since the concatenation was undertaken, and that the earliest of these instances was n days ago:- <OL TYPE=""1"">"
0007rsTableControl.MoveFirst
0008Do While Not rsTableControl.EOF
0009 strList = strList & "<LI><A HREF = """ & prefix & IIf(rsTableControl.Fields(0) = "Supervisions", "../Secure_Jen/", "../Notes/") & Replace(rsTableControl.Fields(0), " ", "") & "ConcatenatedNotes.htm"">" & rsTableControl.Fields(1) & "</A>"
0010 If rsTableControl.Fields(2) > rsTableControl.Fields(3) Then
0011 'Concatenation out of date
0012 i = rsTableControl.Fields(2) - rsTableControl.Fields(3)
0013 strList = strList & " (Out of Date by " & i & " days)"
0014 End If
0015 strList = strList & "</li>"
0016 rsTableControl.MoveNext
0017Loop
0018strList = strList & "</OL></P>"
0019Set rsTableControl = Nothing
0020End Sub

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


Source Code of: Notes_Move_Control
Procedure Type: Public Sub
Module: Notes_Move
Lines of Code: 37
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Notes_Move_Control()
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
0004'Needs to run twice for secure and open Notes
0005Dim fso As FileSystemObject
0006Dim tsTextFileIn As TextStream
0007Dim InFile As String
0008Dim DirectoryName As String
0009Dim MainFolder
0010Dim FileCollection
0011Dim File
0012Dim File_Name As String
0013Dim Note_ID As String
0014Dim New_Directory As String
0015Dim New_File_Name As String
0016Set fso = CreateObject("Scripting.FileSystemObject")
0017DirectoryName = "C:\Theo's Files\Websites\Theo's Website\Secure_Jen\"
0018Set MainFolder = fso.GetFolder(DirectoryName)
0019Set FileCollection = MainFolder.Files
0020For Each File In FileCollection
0021 File_Name = File.Name
0022 Note_ID = Find_NoteID(File_Name) 'Determine Note_ID
0023 If Note_ID = "" Then
0024 Debug.Print Now() & " - "; "ID not Found"
0025 Else
0026 InFile = DirectoryName & File_Name
0027 Set tsTextFileIn = fso.OpenTextFile(InFile, 1, False, 0) 'Open the file
0028 New_Directory = "Notes_" & Find_New_Directory(Note_ID) 'Determine New Folder
0029 New_File_Name = DirectoryName & New_Directory & "\" & File_Name
0030 New_Directory = New_Directory & "/"
0031 'Convert the references in the file (copying as we go)
0032 OK = CopyReplace_TextStream(InFile, New_File_Name, New_Directory)
0033 Set tsTextFileIn = Nothing
0034 End If
0035Next
0036Set fso = Nothing
0037End Sub

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


Source Code of: Notes_Print_Move_Control
Procedure Type: Public Sub
Module: Notes_Print_Move
Lines of Code: 39
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Notes_Print_Move_Control()
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
0004'Needs to run twice for secure and open Notes
0005Dim fso As FileSystemObject
0006Dim tsTextFileIn As TextStream
0007Dim InFile As String
0008Dim DirectoryName As String
0009Dim SubDirectoryName As String
0010Dim MainFolder
0011Dim FileCollection
0012Dim File
0013Dim File_Name As String
0014Dim Note_ID As String
0015Dim New_Directory As String
0016Dim New_File_Name As String
0017Set fso = CreateObject("Scripting.FileSystemObject")
0018DirectoryName = "C:\Theo's Files\Websites\Theo's Website\Notes\"
0019SubDirectoryName = "Notes_Print\"
0020Set MainFolder = fso.GetFolder(DirectoryName & SubDirectoryName)
0021Set FileCollection = MainFolder.Files
0022For Each File In FileCollection
0023 File_Name = File.Name
0024 Note_ID = Find_NoteID_Print(File_Name) 'Determine Note_ID
0025 If Note_ID = "" Then
0026 Debug.Print Now() & " - "; "ID not Found"
0027 Else
0028 InFile = DirectoryName & SubDirectoryName & File_Name
0029 Set tsTextFileIn = fso.OpenTextFile(InFile, 1, False, 0) 'Open the file
0030 New_Directory = "Notes_" & Find_New_Directory(Note_ID) 'Determine New Folder
0031 New_File_Name = DirectoryName & New_Directory & "\" & SubDirectoryName & File_Name
0032 New_Directory = New_Directory & "/"
0033 'Convert the references in the file (copying as we go)
0034 OK = CopyReplace_TextStreamPrint(InFile, New_File_Name)
0035 Set tsTextFileIn = Nothing
0036 End If
0037Next
0038Set fso = Nothing
0039End Sub

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


Source Code of: ReplaceLink
Procedure Type: Public Function
Module: Notes_Move
Lines of Code: 26
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function ReplaceLink(strString, Marker, Pre_Addition)
0002'This module adds Pre_Addition pror to Marker anywhere in strString
0003'The primary usage is to convert references to Books and Papers in Notes consequent on adding an extra level of directory structure
0004Dim lenString As Long
0005Dim lenMarker As Long
0006Dim lenPre As Long
0007Dim strTemp As String
0008Dim x As Long
0009Dim Y As Long
0010strTemp = strString
0011lenString = Len(strTemp)
0012lenMarker = Len(Marker)
0013lenPre = Len(Pre_Addition)
0014x = 1
0015Y = 1
0016Do While Y > 0
0017 Y = InStr(x, strTemp, Marker)
0018 If Y > 0 Then
0019 'Adjust the string
0020 strTemp = Left(strTemp, Y - 1) & Pre_Addition & Mid(strTemp, Y, lenString)
0021 lenString = Len(strTemp)
0022 x = Y + lenPre + 1
0023 End If
0024Loop
0025ReplaceLink = strTemp
0026End Function

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


Source Code of: ReplaceNoteLink
Procedure Type: Public Function
Module: Notes_Move
Lines of Code: 56
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function ReplaceNoteLink(strString, Marker, Ignore_String)
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 lenPre As Long
0007Dim lenIgn As Long
0008Dim strTemp As String
0009Dim x As Long
0010Dim Y As Long
0011Dim NoteID As String
0012Dim Pre_Addition As String
0013Dim len_PreRemoval As Long
0014strTemp = strString
0015lenString = Len(strTemp)
0016lenMarker = Len(Marker)
0017lenIgn = Len(Ignore_String)
0018x = 1
0019Y = 1
0020Do While Y > 0
0021 Y = InStr(x, strTemp, Marker)
0022 If Y > 0 Then
0023 If Mid(strTemp, Y, lenIgn) = Ignore_String Then
0024 x = Y + 1
0025 Else
0026 'Need to determine the right sub-directory
0027 NoteID = Find_NoteID2(Mid(strTemp, Y, Len(strTemp)))
0028 If NoteID <> "" Then
0029 'Check if a cross-security link
0030 If Right(Left(strTemp, Y - 1), 9) = "../Notes/" Then
0031 Pre_Addition = "../../Notes/"
0032 len_PreRemoval = 9
0033 Else
0034 If Right(Left(strTemp, Y - 1), 14) = "../Secure_Jen/" Then
0035 Pre_Addition = "../../Secure_Jen/"
0036 len_PreRemoval = 14
0037 Else
0038 Pre_Addition = "../"
0039 len_PreRemoval = 0
0040 End If
0041 End If
0042 Pre_Addition = Pre_Addition & "Notes_" & Find_New_Directory(NoteID) & "/"
0043 Else
0044 Pre_Addition = ""
0045 len_PreRemoval = 0
0046 End If
0047 lenPre = Len(Pre_Addition)
0048 'Adjust the string
0049 strTemp = Left(strTemp, Y - 1 - len_PreRemoval) & Pre_Addition & Mid(strTemp, Y, lenString)
0050 lenString = Len(strTemp)
0051 x = Y - len_PreRemoval + lenPre + 1
0052 End If
0053 End If
0054Loop
0055ReplaceNoteLink = strTemp
0056End Function

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


Source Code of: Update_Note_Groups_Latest_Timestamp
Procedure Type: Public Sub
Module: New Code
Lines of Code: 19

Line-No. / Ref.Code Line
0001Public Sub Update_Note_Groups_Latest_Timestamp()
0002Dim rsTableToRead As Recordset
0003Dim rsTableToRead2 As Recordset
0004Dim strQuery As String
0005 strQuery = "SELECT Notes.Note_Group, Max(Notes.Last_Changed) AS MaxOfLast_Changed FROM Notes GROUP BY Notes.Note_Group;"
0006Set rsTableToRead2 = CurrentDb.OpenRecordset(strQuery)
0007rsTableToRead2.MoveFirst
0008Do While Not rsTableToRead2.EOF
0009 'Update the Notes_Group "Last Note Updated" Timestamp
0010 Set rsTableToRead = CurrentDb.OpenRecordset("Select Latest_Note_Update FROM Note_Groups WHERE ID = " & rsTableToRead2.Fields(0) & ";")
0011 rsTableToRead.MoveFirst
0012 rsTableToRead.Edit
0013 rsTableToRead.Fields(0) = rsTableToRead2.Fields(1) / 1000
0014 rsTableToRead.Update
0015 rsTableToRead2.MoveNext
0016Loop
0017Set rsTableToRead = Nothing
0018Set rsTableToRead2 = Nothing
0019End Sub

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


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