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: 216
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
0032Set fsoTextFile = New FileSystemObject
0033strFolder = strOutputFolder
0034StartTime = Now()
0035'Read the data for Citations of this Book
0036Set rsTableToRead = CurrentDb.OpenRecordset(strDataQuery)
0037If Not rsTableToRead.EOF Then
0038 rsTableToRead.MoveFirst
0039 iTableColumns = rsTableToRead.Fields.Count
0040 '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
0041 Book_ID_Previous = 0 'There is no Book_ID 0
0042 strFileSuffix = ""
0043 strFileBody = ""
0044 Do Until rsTableToRead.EOF
0045 Book_ID = rsTableToRead.Fields(0)
0046 ObjectID = rsTableToRead.Fields(iTableColumns - 3)
0047 If Book_ID_Previous <> Book_ID Then 'New Book
0048 'Read the Book Author & Title
0049 strQry = "Select Books.Title, Books.Author from Books Where Books.ID1 = " & Book_ID & ";"
0050 Set rsBooks = CurrentDb.OpenRecordset(strQry)
0051 rsBooks.MoveFirst
0052 'Write the previous Footer (except first time)
0053 If Book_ID_Previous <> 0 Then
0054 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;"
0055 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0056 rsTableControl.MoveFirst
0057 Do While Not rsTableControl.EOF
0058 Time_Stamp = rsTableControl.Fields(0) & ""
0059 OK = Replace_Timestamp(Time_Stamp)
0060 tsTextFile.WriteLine Time_Stamp
0061 rsTableControl.MoveNext
0062 Loop
0063 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0064 iCount = iCount + 1
0065 End If
0066 Book_ID_Previous = Book_ID
0067 strFileSuffix = strOutputFileShort & "_" & Book_ID
0068 strFileBody = "BookSummary_" & Mid(100000 + Book_ID, 2, 2)
0069 'Create File
0070 Set tsTextFile = fsoTextFile.CreateTextFile(strOutputFolder & strFileBody & "\" & strFileSuffix & ".htm", True, True)
0071 'Page Header
0072 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;"
0073 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0074 rsTableControl.MoveFirst
0075 Do While Not rsTableControl.EOF
0076 strLine = rsTableControl.Fields(0) & ""
0077 x = InStr(1, strLine, "**BOOK**")
0078 If x > 0 Then
0079 'Add the Book Title
0080 strLine = Left(strLine, x - 1) & "<A HREF = ""BookSummary_" & Book_ID & ".htm"">" & rsBooks.Fields(0).Value & "</a>" & Mid(strLine, x + 8, Len(strLine))
0081 End If
0082 x = InStr(1, strLine, "**AUTHOR**")
0083 If x > 0 Then
0084 'Add the Book Author
0085 strAuthors = rsBooks.Fields(1)
0086 OK = Author_Reference_String(strAuthors, 2)
0087 strLine = Left(strLine, x - 1) & strAuthors & Mid(strLine, x + 10, Len(strLine))
0088 End If
0089 tsTextFile.WriteLine strLine
0090 rsTableControl.MoveNext
0091 Loop
0092 'Read Table-Control for rows
0093 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;"
0094 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0095 'Table Column Headings
0096 rsTableControl.MoveFirst
0097 Do While Not rsTableControl.EOF
0098 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0099 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0100 '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
0101 If iFieldNo > 0 And iFieldNo <= iTableColumns - 3 Then
0102 If iFieldNo = 6 Then
0103 tsTextFile.WriteLine "</td><td width=""10%"" class = ""BridgeLeft""><B>Repeats ...</B></td>"
0104 Else
0105 tsTextFile.WriteLine "<B> " & rsTableToRead.Fields(iFieldNo).Name & "</B>"
0106 End If
0107 End If
0108 Else
0109 tsTextFile.WriteLine rsTableControl.Fields(0) & ""
0110 End If
0111 rsTableControl.MoveNext
0112 Loop
0113 End If
0114 'Table Row
0115 rsTableControl.MoveFirst
0116 Do While Not rsTableControl.EOF
0117 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0118 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0119 If iFieldNo > 0 And iFieldNo <= iTableColumns - 2 Then
0120 If Len(rsTableToRead.Fields(iFieldNo) & "") = 0 Then
0121 strLine = "&nbsp;"
0122 Else
0123 Select Case rsTableToRead.Fields(iFieldNo).Name
0124 Case "Title"
0125 If rsTableToRead.Fields(5).Value = "." Then 'No further information
0126 strLine = rsTableToRead.Fields(iFieldNo).Value
0127 Else
0128 If rsTableToRead.Fields(iTableColumns - 2) = "Paper" Then
0129 strLine = "<A HREF = ""../../PaperSummaries/PaperSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/PaperSummary_" & ObjectID & ".htm"">" & rsTableToRead.Fields(iFieldNo).Value & "</A>"
0130 Else
0131 strLine = "<A HREF = ""../../BookSummaries/BookSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/BookSummary_" & ObjectID & ".htm"">" & rsTableToRead.Fields(iFieldNo).Value & "</A>"
0132 End If
0133 End If
0134 Case "Further Information"
0135 Saved_Link_Type = rsTableToRead.Fields(iTableColumns - 2)
0136 Saved_ObjectID = ObjectID
0137 If rsTableToRead.Fields(iFieldNo).Value = "." Then
0138 If Saved_Link_Type = "Paper" Then
0139 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>"
0140 Else
0141 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>"
0142 End If
0143 Else
0144 If Saved_Link_Type = "Paper" Then
0145 strLine = "<A HREF = ""../../Abstracts/Abstract_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/Abstract_" & ObjectID & ".htm#" & rsTableToRead.Fields(iTableColumns - 1) & """>Paper Abstract</A>"
0146 Else
0147 strLine = "<A HREF = ""../../BookSummaries/BookSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/BookPaperAbstracts/BookPaperAbstracts_" & ObjectID & ".htm#" & rsTableToRead.Fields(iTableColumns - 1) & """>Book Abstract</A>"
0148 End If
0149 strLine = strLine & rsTableToRead.Fields(iFieldNo).Value & "</td>"
0150 rsTableToRead.MoveNext
0151 DoneEnough = False
0152 If Not rsTableToRead.EOF Then
0153 strLine = strLine & "<td width=""10%"" class = ""BridgeLeft"">"
0154 StrComma = ""
0155 iExtras = 1
0156 Do Until DoneEnough = True
0157 If Saved_Link_Type = rsTableToRead.Fields(iTableColumns - 2) And ObjectID = rsTableToRead.Fields(iTableColumns - 3) And Book_ID = rsTableToRead.Fields(0) Then
0158 If Saved_Link_Type = "Paper" Then
0159 strLine = strLine & StrComma & "<A HREF = ""../../Abstracts/Abstract_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/Abstract_" & ObjectID & ".htm#" & rsTableToRead.Fields(iTableColumns - 1) & """>" & iExtras & "</A>"
0160 Else
0161 strLine = strLine & StrComma & "<A HREF = ""../../BookSummaries/BookSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/BookPaperAbstracts/BookPaperAbstracts_" & ObjectID & ".htm#" & rsTableToRead.Fields(iTableColumns - 1) & """>" & iExtras & "</A>"
0162 End If
0163 rsTableToRead.MoveNext
0164 If rsTableToRead.EOF Then
0165 DoneEnough = True
0166 rsTableToRead.MovePrevious
0167 Else
0168 StrComma = ", "
0169 iExtras = iExtras + 1
0170 End If
0171 Else
0172 DoneEnough = True
0173 rsTableToRead.MovePrevious
0174 End If
0175 Loop
0176 strLine = strLine & "</td>"
0177 Else
0178 strLine = strLine & "<td width=""10%"" class = ""BridgeLeft"">&nbsp;</td>"
0179 rsTableToRead.MovePrevious
0180 End If
0181 End If
0182 Case Else
0183 If iFieldNo = 6 Then
0184 strLine = ""
0185 Else
0186 strLine = rsTableToRead.Fields(iFieldNo)
0187 End If
0188 End Select
0189 End If
0190 strLine = ReplaceCode(strLine, Chr(13) & Chr(10), "<BR>")
0191 tsTextFile.WriteLine strLine
0192 End If
0193 Else
0194 tsTextFile.WriteLine rsTableControl.Fields(0) & ""
0195 End If
0196 rsTableControl.MoveNext
0197 Loop
0198 rsTableToRead.MoveNext
0199 Loop
0200 'Write the Last Footer
0201 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;"
0202 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0203 rsTableControl.MoveFirst
0204 Do While Not rsTableControl.EOF
0205 Time_Stamp = rsTableControl.Fields(0) & ""
0206 OK = Replace_Timestamp(Time_Stamp)
0207 tsTextFile.WriteLine Time_Stamp
0208 rsTableControl.MoveNext
0209 Loop
0210 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0211 iCount = iCount + 1
0212End If
0213If Automatic = "No" Then
0214 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"
0215End If
0216End 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: 177
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
0027iCount = 0
0028Set fsoTextFile = New FileSystemObject
0029strFolder = strOutputFolder
0030StartTime = Now()
0031'Read the data for Citations of this Paper
0032Set rsTableToRead = CurrentDb.OpenRecordset(strDataQuery)
0033If Not rsTableToRead.EOF Then
0034 rsTableToRead.MoveFirst
0035 iTableColumns = rsTableToRead.Fields.Count
0036 '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
0037 Paper_ID_Previous = 0 'There is no Paper_ID 0
0038 strFileSuffix = ""
0039 strFileBody = ""
0040 Do Until rsTableToRead.EOF
0041 Paper_ID = rsTableToRead.Fields(0)
0042 ObjectID = rsTableToRead.Fields(iTableColumns - 3)
0043 If Paper_ID_Previous <> Paper_ID Then 'New Paper
0044 'Read the Paper Author & Title
0045 strQry = "Select Papers.Title, Papers.Author from Papers Where Papers.ID = " & Paper_ID & ";"
0046 Set rsPapers = CurrentDb.OpenRecordset(strQry)
0047 If Not rsPapers.EOF Then
0048 rsPapers.MoveFirst
0049 strAuthors = rsPapers.Fields(1)
0050 strPaper = rsPapers.Fields(0)
0051 Else
0052 strAuthors = "Unknown Author"
0053 strPaper = "Unknown Paper"
0054 End If
0055 'Write the previous Footer (except first time)
0056 If Paper_ID_Previous <> 0 Then
0057 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;"
0058 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0059 rsTableControl.MoveFirst
0060 Do While Not rsTableControl.EOF
0061 Time_Stamp = rsTableControl.Fields(0) & ""
0062 OK = Replace_Timestamp(Time_Stamp)
0063 tsTextFile.WriteLine Time_Stamp
0064 rsTableControl.MoveNext
0065 Loop
0066 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0067 iCount = iCount + 1
0068 End If
0069 Paper_ID_Previous = Paper_ID
0070 strFileSuffix = strOutputFileShort & "_" & Paper_ID
0071 strFileBody = "PaperSummary_" & Mid(100000 + Paper_ID, 2, 2)
0072 'Create File
0073 Set tsTextFile = fsoTextFile.CreateTextFile(strOutputFolder & strFileBody & "\" & strFileSuffix & ".htm", True, True)
0074 'Page Header
0075 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;"
0076 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0077 rsTableControl.MoveFirst
0078 Do While Not rsTableControl.EOF
0079 strLine = rsTableControl.Fields(0) & ""
0080 x = InStr(1, strLine, "**PAPER**")
0081 If x > 0 Then
0082 'Add the Paper Title
0083 strLine = Left(strLine, x - 1) & "<A HREF = ""PaperSummary_" & Paper_ID & ".htm"">" & strPaper & "</a>" & Mid(strLine, x + 9, Len(strLine))
0084 End If
0085 x = InStr(1, strLine, "**AUTHOR**")
0086 If x > 0 Then
0087 'Add the Paper Author
0088 OK = Author_Reference_String(strAuthors, 2)
0089 strLine = Left(strLine, x - 1) & strAuthors & Mid(strLine, x + 10, Len(strLine))
0090 End If
0091 tsTextFile.WriteLine strLine
0092 rsTableControl.MoveNext
0093 Loop
0094 'Read Table-Control for rows
0095 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;"
0096 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0097 'Table Column Headings
0098 rsTableControl.MoveFirst
0099 Do While Not rsTableControl.EOF
0100 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0101 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0102 'Note: Fields start at 0, but the first one in the query is the Paper, and the last one is the Object ID
0103 If iFieldNo > 0 And iFieldNo <= iTableColumns - 2 Then
0104 tsTextFile.WriteLine "<B> " & rsTableToRead.Fields(iFieldNo).Name & "</B>"
0105 End If
0106 Else
0107 tsTextFile.WriteLine rsTableControl.Fields(0) & ""
0108 End If
0109 rsTableControl.MoveNext
0110 Loop
0111 End If
0112 'Table Row
0113 rsTableControl.MoveFirst
0114 Do While Not rsTableControl.EOF
0115 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0116 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0117 If iFieldNo > 0 And iFieldNo <= iTableColumns - 2 Then
0118 If Len(rsTableToRead.Fields(iFieldNo) & "") = 0 Then
0119 strLine = "&nbsp;"
0120 Else
0121 Select Case rsTableToRead.Fields(iFieldNo).Name
0122 Case "Title"
0123 If rsTableToRead.Fields(5).Value <> "." Then
0124 If rsTableToRead.Fields(iTableColumns - 2) = "Paper" Then
0125 strLine = "<A HREF = ""../../PaperSummaries/PaperSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/PaperSummary_" & ObjectID & ".htm"">" & rsTableToRead.Fields(iFieldNo) & "</A>"
0126 Else
0127 strLine = "<A HREF = ""../../BookSummaries/BookSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/BookSummary_" & ObjectID & ".htm"">" & rsTableToRead.Fields(iFieldNo) & "</A>"
0128 End If
0129 Else
0130 strLine = rsTableToRead.Fields(iFieldNo)
0131 End If
0132 Case "Further Information"
0133 If rsTableToRead.Fields(iFieldNo).Value = "." Then
0134 If rsTableToRead.Fields(iTableColumns - 2) = "Paper" Then
0135 strLine = "<A HREF = ""../../PaperSummaries/PaperSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/PaperSummary_" & ObjectID & ".htm"">Paper</A>"
0136 Else
0137 strLine = "<A HREF = ""../../BookSummaries/BookSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/BookSummary_" & ObjectID & ".htm"">Book</A>"
0138 End If
0139 Else
0140 If rsTableToRead.Fields(iTableColumns - 2) = "Paper" Then
0141 strLine = "<A HREF = ""../../Abstracts/Abstract_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/Abstract_" & ObjectID & ".htm#" & rsTableToRead.Fields(iTableColumns - 1) & """>Paper Abstract</A>"
0142 Else
0143 strLine = "<A HREF = ""../../BookSummaries/BookSummary_" & Right(Str(Int(ObjectID / 1000) + 1000000), 2) & "/BookPaperAbstracts/BookPaperAbstracts_" & ObjectID & ".htm#" & rsTableToRead.Fields(iTableColumns - 1) & """>Book Abstract</A>"
0144 End If
0145 strLine = strLine & rsTableToRead.Fields(iFieldNo).Value
0146 End If
0147 Case Else
0148 strLine = rsTableToRead.Fields(iFieldNo)
0149 End Select
0150 End If
0151 strLine = ReplaceCode(strLine, Chr(13) & Chr(10), "<BR>")
0152 tsTextFile.WriteLine strLine
0153 End If
0154 Else
0155 tsTextFile.WriteLine rsTableControl.Fields(0) & ""
0156 End If
0157 rsTableControl.MoveNext
0158 Loop
0159 rsTableToRead.MoveNext
0160 Loop
0161 'Write the Last Footer
0162 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;"
0163 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0164 rsTableControl.MoveFirst
0165 Do While Not rsTableControl.EOF
0166 Time_Stamp = rsTableControl.Fields(0) & ""
0167 OK = Replace_Timestamp(Time_Stamp)
0168 tsTextFile.WriteLine Time_Stamp
0169 rsTableControl.MoveNext
0170 Loop
0171 OK = CopyToTransfer(strFolder & strFileBody & "\", strFileSuffix & ".htm")
0172 iCount = iCount + 1
0173End If
0174If Automatic = "No" Then
0175 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"
0176End If
0177End 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 - 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