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

CreatePapersWebTableFind_Master_NotesImport_DataJumpTableTitles
JumpTableTitles_Recent_Control...

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

Go to top of page



Source Code of: CreatePapersWebTable
Procedure Type: Public Sub
Module: General_Subroutines
Lines of Code: 829
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub CreatePapersWebTable()
0002Dim fsoTextFile As FileSystemObject
0003Dim strFileSuffix As String
0004Dim strFileSuffix_Previous As String
0005Dim strFileTitle As String
0006Dim strFileTitle_Previous As String
0007Dim tsTextFile As TextStream
0008Dim tsJumpFile As TextStream
0009Dim tsJumpFile2 As TextStream
0010Dim tsJumpFile3 As TextStream
0011Dim rsAbstractQuality As Recordset
0012Dim rsTableToRead As Recordset
0013Dim rsTableToReadLetters As Recordset
0014Dim rsTableToReadJump2 As Recordset
0015Dim rsTableToReadJump3 As Recordset
0016Dim rsTableToReadJump4 As Recordset
0017Dim rsTableControl As Recordset
0018Dim rsTableControl2 As Recordset
0019Dim rsTableControl3 As Recordset
0020Dim rsTableControl_BB As Recordset
0021Dim strControlQuery As String
0022Dim strLine As String
0023Dim strQuery As String
0024Dim iTableColumns As Integer
0025Dim iFieldNo As Integer
0026Dim iIDCol As Integer
0027Dim x As Integer
0028Dim Y As String
0029Dim z As String
0030Dim z1 As String
0031Dim z2 As String
0032Dim strLetter As String
0033Dim strLetter_Title As String
0034Dim strControlBreak As String
0035Dim strControlBreak_Last As String
0036Dim strCol1Break As String
0037Dim strCol1Break_Last As String
0038Dim strLine_SavedHeader As String
0039Dim strLine_SavedFooter As String
0040Dim i As Integer
0041Dim strLetter_Title_Short As String
0042Dim strLetter_Title2 As String
0043Dim Jump_type As Integer
0044Dim File_Suffix As String
0045Dim start As Date
0046Dim strNextPageQuery As String
0047Dim NextPage As String
0048Dim NextPageID As String
0049Dim LeftLink As String
0050Dim RightLink As String
0051Dim LinkTable As String
0052Dim Toplink As String
0053Dim MaxLen As Integer
0054Dim Time_Stamp As String
0055Dim RightPct As Integer
0056Dim LeftPct As Integer
0057Dim RightLen As Integer
0058Dim LeftLen As Integer
0059start = Now()
0060Set fsoTextFile = New FileSystemObject
0061'Create Control File
0062strFolder = strOutputFolder
0063strFileName = strOutputFileShort & ".htm"
0064Set tsTextFile = fsoTextFile.CreateTextFile(strFolder & strFileName, True, True)
0065strLine_SavedHeader = ""
0066'Find Footer for BB Pages
0067strLine_SavedFooter = ""
0068 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;"
0069Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0070rsTableControl.MoveFirst
0071Do While Not rsTableControl.EOF
0072 strLine_SavedFooter = strLine_SavedFooter & rsTableControl.Fields(0)
0073 rsTableControl.MoveNext
0074Loop
0075 OK = Replace_Timestamp(strLine_SavedFooter)
0076'Control Page Header
0077If Main_Header = "Yes" Then
0078 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""MainHeader"")) ORDER BY Website_Control.Line;"
0079Else
0080 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;"
0081End If
0082Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0083rsTableControl.MoveFirst
0084Do While Not rsTableControl.EOF
0085 strLine = rsTableControl.Fields(0) & ""
0086 x = InStr(1, strLine, "**TITLE_HEAD**")
0087 If x > 0 Then
0088 strLine = Left(strLine, x - 1) & Mid(strLine, x + 15, Len(strLine))
0089 End If
0090 x = InStr(1, strLine, "**SECTION**")
0091 If x > 0 Then
0092 'Set up the "jump" table
0093 If strControlBreakType2 = "BB" Then
0094 strLine = "<BR><P ALIGN = ""Left""><FONT Size = 2 FACE=""Arial"">"
0095 tsTextFile.WriteLine strLine
0096 'Re-create the BB_Control table
0097 DoCmd.OpenQuery ("BB_Control_Zap")
0098 DoCmd.OpenQuery (strDataQuery & " (ControlGEN)")
0099 BB_Control_GEN
0100 'Level 1 jump
0101 strControlQuery = "SELECT BB_Control.Level_5, Min(BB_Control.Primary_Break) AS MinOfPrimary_Break, Max(BB_Control.Primary_Break) AS MaxOfPrimary_Break FROM BB_Control GROUP BY BB_Control.Level_5;"
0102 Set rsTableToReadLetters = CurrentDb.OpenRecordset(strControlQuery)
0103 rsTableToReadLetters.MoveFirst
0104 strLine = "<B><U>Level 1 Jump</B></U><BR><BR>"
0105 tsTextFile.WriteLine strLine
0106 Do While Not rsTableToReadLetters.EOF
0107 strLine = "<A HREF=""" & strOutputFileShort & "_" & rsTableToReadLetters.Fields(0) & ".htm"">" & rsTableToReadLetters.Fields(1) & " - " & rsTableToReadLetters.Fields(2) & "</A><BR>"
0108 tsTextFile.WriteLine strLine
0109 rsTableToReadLetters.MoveNext
0110 Loop
0111 strLine = strLine_SavedFooter
0112 tsTextFile.WriteLine strLine
0113 'Level 2 jump
0114 rsTableToReadLetters.MoveFirst
0115 Do While Not rsTableToReadLetters.EOF
0116 Set tsJumpFile = fsoTextFile.CreateTextFile(strOutputFile & "_" & rsTableToReadLetters.Fields(0) & ".htm", True, True)
0117 strLine = strLine_SavedHeader & "<BR><B><U>Level 2 Jump</B></U><BR><BR>"
0118 tsJumpFile.WriteLine strLine
0119 strControlQuery = "SELECT BB_Control.Level_4, Min(BB_Control.Primary_Break) AS MinOfPrimary_Break, Max(BB_Control.Primary_Break) AS MaxOfPrimary_Break FROM BB_Control WHERE (((BB_Control.Level_5) = " & rsTableToReadLetters.Fields(0) & ")) GROUP BY BB_Control.Level_4;"
0120 Set rsTableToReadJump2 = CurrentDb.OpenRecordset(strControlQuery)
0121 rsTableToReadJump2.MoveFirst
0122 Do While Not rsTableToReadJump2.EOF
0123 strLine = "<A HREF=""" & strOutputFileShort & "_" & rsTableToReadLetters.Fields(0) & "_" & rsTableToReadJump2.Fields(0) & ".htm"">" & rsTableToReadJump2.Fields(1) & " - " & rsTableToReadJump2.Fields(2) & "</A><BR>"
0124 tsJumpFile.WriteLine strLine
0125 'Level 3 Jump
0126 Set tsJumpFile2 = fsoTextFile.CreateTextFile(strOutputFile & "_" & rsTableToReadLetters.Fields(0) & "_" & rsTableToReadJump2.Fields(0) & ".htm", True, True)
0127 strLine = strLine_SavedHeader & "<BR><B><U>Level 3 Jump</B></U><BR><BR>"
0128 tsJumpFile2.WriteLine strLine
0129 strControlQuery = "SELECT BB_Control.Level_3, Min(BB_Control.Primary_Break) AS MinOfPrimary_Break, Max(BB_Control.Primary_Break) AS MaxOfPrimary_Break FROM BB_Control WHERE (((BB_Control.Level_5) = " & rsTableToReadLetters.Fields(0) & ")) GROUP BY BB_Control.Level_3, BB_Control.Level_4 HAVING (((BB_Control.Level_4)= " & rsTableToReadJump2.Fields(0) & "));"
0130 Set rsTableToReadJump3 = CurrentDb.OpenRecordset(strControlQuery)
0131 rsTableToReadJump3.MoveFirst
0132 Do While Not rsTableToReadJump3.EOF
0133 strLine = "<A HREF=""" & strOutputFileShort & "_" & rsTableToReadLetters.Fields(0) & "_" & rsTableToReadJump2.Fields(0) & "_" & rsTableToReadJump3.Fields(0) & ".htm"">" & rsTableToReadJump3.Fields(1) & " - " & rsTableToReadJump3.Fields(2) & "</A><BR>"
0134 tsJumpFile2.WriteLine strLine
0135 'Level 4 Jump
0136 Set tsJumpFile3 = fsoTextFile.CreateTextFile(strOutputFile & "_" & rsTableToReadLetters.Fields(0) & "_" & rsTableToReadJump2.Fields(0) & "_" & rsTableToReadJump3.Fields(0) & ".htm", True, True)
0137 strLine = strLine_SavedHeader & "<BR><B><U>Level 4 Jump</B></U><BR><BR>"
0138 tsJumpFile3.WriteLine strLine
0139 strControlQuery = "SELECT BB_Control.Level_2, Min(BB_Control.Primary_Break) AS MinOfPrimary_Break, Max(BB_Control.Primary_Break) AS MaxOfPrimary_Break FROM BB_Control WHERE (((BB_Control.Level_3) = " & rsTableToReadJump3.Fields(0) & ") And ((BB_Control.Level_4) = " & rsTableToReadJump2.Fields(0) & ") And ((BB_Control.Level_5) = " & rsTableToReadLetters.Fields(0) & ")) GROUP BY BB_Control.Level_2;"
0140 Set rsTableToReadJump4 = CurrentDb.OpenRecordset(strControlQuery)
0141 rsTableToReadJump4.MoveFirst
0142 Do While Not rsTableToReadJump4.EOF
0143 strLine = "<A HREF=""" & strOutputFileShort & "_" & rsTableToReadLetters.Fields(0) & "_" & rsTableToReadJump2.Fields(0) & "_" & rsTableToReadJump3.Fields(0) & "_" & rsTableToReadJump4.Fields(0) & ".htm"">" & rsTableToReadJump4.Fields(1) & " - " & rsTableToReadJump4.Fields(2) & "</A><BR>"
0144 tsJumpFile3.WriteLine strLine
0145 rsTableToReadJump4.MoveNext
0146 Loop
0147 strLine = strLine_SavedFooter
0148 tsJumpFile3.WriteLine strLine
0149 OK = CopyToTransfer(strFolder, strOutputFileShort & "_" & rsTableToReadLetters.Fields(0) & "_" & rsTableToReadJump2.Fields(0) & "_" & rsTableToReadJump3.Fields(0) & ".htm")
0150 Set tsJumpFile3 = Nothing
0151 Set rsTableToReadJump4 = Nothing
0152 rsTableToReadJump3.MoveNext
0153 Loop
0154 strLine = strLine_SavedFooter
0155 tsJumpFile2.WriteLine strLine
0156 OK = CopyToTransfer(strFolder, strOutputFileShort & "_" & rsTableToReadLetters.Fields(0) & "_" & rsTableToReadJump2.Fields(0) & ".htm")
0157 Set tsJumpFile2 = Nothing
0158 Set rsTableToReadJump3 = Nothing
0159 rsTableToReadJump2.MoveNext
0160 Loop
0161 strLine = strLine_SavedFooter
0162 tsJumpFile.WriteLine strLine
0163 OK = CopyToTransfer(strFolder, strOutputFileShort & "_" & rsTableToReadLetters.Fields(0) & ".htm")
0164 rsTableToReadLetters.MoveNext
0165 Set tsJumpFile = Nothing
0166 Set rsTableToReadJump2 = Nothing
0167 Loop
0168 Set rsTableToReadLetters = Nothing
0169 Else
0170 If strControlBreakType = "Initial" Then 'Initial-letter jump table
0171 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = ""Jump_Table"") And ((Website_Control.Section) = ""All"")) ORDER BY Website_Control.Line;"
0172 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0173 rsTableControl2.MoveFirst
0174 Set rsTableToReadLetters = CurrentDb.OpenRecordset(strDataQuery & " (Letters)")
0175 If Not rsTableToReadLetters.EOF Then
0176 rsTableToReadLetters.MoveFirst
0177 strLetter = rsTableToReadLetters.Fields(0)
0178 Do While Not rsTableControl2.EOF
0179 strLine = rsTableControl2.Fields(0) & ""
0180 x = InStr(1, strLine, "**Column")
0181 If x > 0 Then
0182 Y = Mid(strLine, x + 8, 1)
0183 If Y < strLetter Then
0184 strLine = Left(strLine, x - 1) & "." & Mid(strLine, x + 11, Len(strLine))
0185 Else
0186 If strSplitTable = "No" Then
0187 Y = "<A HREF=""#Section" & Y & """>" & Y & "</A>"
0188 Else
0189 Y = "<A HREF=""" & strOutputFileShort & "_" & Y & ".htm"">" & Y & "</A>"
0190 End If
0191 strLine = Left(strLine, x - 1) & Y & Mid(strLine, x + 11, Len(strLine))
0192 If Not rsTableToReadLetters.EOF Then
0193 rsTableToReadLetters.MoveNext
0194 If Not rsTableToReadLetters.EOF Then
0195 strLetter = Left(rsTableToReadLetters.Fields(0), 1)
0196 Else
0197 strLetter = "ZZZ"
0198 End If
0199 End If
0200 End If
0201 tsTextFile.WriteLine strLine
0202 Else
0203 tsTextFile.WriteLine strLine
0204 End If
0205 rsTableControl2.MoveNext
0206 Loop
0207 End If
0208 Else
0209 'Title-based jump table
0210 ' ... Header
0211 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = ""Jump_Table_Titles"") And ((Website_Control.Section) = ""Header"")) ORDER BY Website_Control.Line;"
0212 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0213 rsTableControl2.MoveFirst
0214 Do While Not rsTableControl2.EOF
0215 strLine = rsTableControl2.Fields(0) & ""
0216 tsTextFile.WriteLine strLine
0217 rsTableControl2.MoveNext
0218 Loop
0219 ' ... Rows
0220 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = ""Jump_Table_Titles"") And ((Website_Control.Section) = ""Rows"")) ORDER BY Website_Control.Line;"
0221 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0222 rsTableControl2.MoveFirst
0223 If strControlBreakType2 = "2-Level" Then
0224 Set rsTableToReadLetters = CurrentDb.OpenRecordset(strDataQuery & " (Titles) - Top")
0225 Else
0226 Set rsTableToReadLetters = CurrentDb.OpenRecordset(strDataQuery & " (Titles)")
0227 End If
0228 rsTableToReadLetters.MoveFirst
0229 z = rsTableToReadLetters.Fields(0).Name
0230 z1 = rsTableToReadLetters.Fields(1).Name
0231 strLetter = rsTableToReadLetters.Fields(1) 'Note: this is the internal ID of the field
0232 strLetter_Title = rsTableToReadLetters.Fields(0)
0233 Do While (Not rsTableControl2.EOF Or Not rsTableToReadLetters.EOF)
0234 If rsTableControl2.EOF Then
0235 rsTableControl2.MoveFirst
0236 End If
0237 If strSplitTable = "No" Then
0238 Else
0239 Jump_type = 1
0240 If rsTableToReadLetters.Fields.Count > 2 Then
0241 If Not rsTableToReadLetters.EOF Then
0242 If rsTableToReadLetters.Fields(2) = 1 Then
0243 Jump_type = 1
0244 Else
0245 Jump_type = 2
0246 End If
0247 End If
0248 End If
0249 End If
0250 strLine = rsTableControl2.Fields(0) & ""
0251 x = InStr(1, strLine, "**Column")
0252 If x > 0 Then
0253 If strLetter <> "" Then
0254 If strSplitTable = "No" Then
0255 If InStr(strLetter_Title, "<BR>") > 0 Then
0256 strLetter_Title_Short = Left(strLetter_Title, InStr(strLetter_Title, "<BR>") - 1)
0257 Else
0258 strLetter_Title_Short = strLetter_Title
0259 End If
0260 Y = "<A HREF=""#Section" & Replace(strLetter_Title_Short, " ", "_") & """>" & strLetter_Title & "</A>"
0261 Else
0262 If strControlBreakType2 = "2-Level" Then
0263 If Jump_type = 2 Then
0264 Y = "<A HREF=""" & strOutputFileShort & "_Top_" & strLetter & ".htm"">" & strLetter_Title & "</A>"
0265 Else
0266 File_Suffix = strLetter
0267 Y = "<A HREF=""" & strOutputFileShort & "_" & File_Suffix & ".htm"">" & strLetter_Title & "</A>"
0268 End If
0269 Else
0270 Y = "<A HREF=""" & strOutputFileShort & "_" & strLetter & ".htm"">" & strLetter_Title & "</A>"
0271 End If
0272 End If
0273 Else
0274 Y = "."
0275 End If
0276 strLine = Left(strLine, x - 1) & Y & Mid(strLine, x + 10, Len(strLine))
0277 If Not rsTableToReadLetters.EOF Then
0278 rsTableToReadLetters.MoveNext
0279 If Not rsTableToReadLetters.EOF Then
0280 strLetter = rsTableToReadLetters.Fields(1)
0281 strLetter_Title = rsTableToReadLetters.Fields(0)
0282 If strControlBreakType2 = "2-Level" Then
0283 If rsTableToReadLetters.Fields(2) = 1 Then
0284 Jump_type = 1
0285 Else
0286 Jump_type = 2
0287 End If
0288 End If
0289 Else
0290 strLetter = ""
0291 End If
0292 End If
0293 tsTextFile.WriteLine strLine
0294 Else
0295 tsTextFile.WriteLine strLine
0296 End If
0297 rsTableControl2.MoveNext
0298 Loop
0299 ' ... Footer
0300 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = ""Jump_Table_Titles"") And ((Website_Control.Section) = ""Footer"")) ORDER BY Website_Control.Line;"
0301 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0302 rsTableControl2.MoveFirst
0303 Do While Not rsTableControl2.EOF
0304 strLine = rsTableControl2.Fields(0) & ""
0305 tsTextFile.WriteLine strLine
0306 rsTableControl2.MoveNext
0307 Loop
0308 If strControlBreakType2 = "2-Level" Then
0309 'Add a second-level set of Jump tables if necessary
0310 Set rsTableToReadJump4 = CurrentDb.OpenRecordset(strDataQuery & " (Titles) - Top")
0311 rsTableToReadJump4.MoveFirst
0312 Do While Not rsTableToReadJump4.EOF
0313 If rsTableToReadJump4.Fields(2) > 1 Then
0314 strLetter_Title2 = rsTableToReadJump4.Fields(1)
0315 strLetter_Title_Short = Left(rsTableToReadJump4.Fields(0), InStr(rsTableToReadJump4.Fields(0), "<BR>") - 1)
0316 Set tsJumpFile = fsoTextFile.CreateTextFile(strOutputFile & "_Top_" & strLetter_Title2 & ".htm", True, True)
0317 'Page Header
0318 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;"
0319 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0320 rsTableControl2.MoveFirst
0321 Do While Not rsTableControl2.EOF
0322 strLine = rsTableControl2.Fields(0) & ""
0323 x = InStr(1, strLine, "**TITLE_HEAD**")
0324 If x > 0 Then
0325 strLine = Left(strLine, x - 1) & rsTableToReadJump4.Fields(0) & " - " & Mid(strLine, x + 15, Len(strLine))
0326 strLine = Replace(strLine, "<BR>", " ")
0327 End If
0328 x = InStr(1, strLine, "**SECTION**")
0329 If x > 0 Then
0330 strLine = Left(strLine, x - 1) & ": " & rsTableToReadJump4.Fields(0) & Mid(strLine, x + 11, Len(strLine))
0331 'Find Next page
0332 strNextPageQuery = "SELECT [" & strDataQuery & " (Titles) - Top].* FROM [" & strDataQuery & " (Titles) - Top];"
0333 Set rsTableControl3 = CurrentDb.OpenRecordset(strNextPageQuery)
0334 rsTableControl3.MoveFirst
0335 z = rsTableControl3.Fields(0).Name
0336 z1 = rsTableControl3.Fields(1).Name
0337 z2 = rsTableControl3.Fields(2).Name
0338 strNextPageQuery = "SELECT [" & strDataQuery & " (Titles) - Top].[" & z & "], [" & strDataQuery & " (Titles) - Top].[" & z1 & "], [" & strDataQuery & " (Titles) - Top].[" & z2 & "] FROM [" & strDataQuery & " (Titles) - Top] WHERE ((([" & strDataQuery & " (Titles) - Top].[" & z & "])>""" & rsTableToReadJump4.Fields(0).Value & """)) ORDER BY [" & strDataQuery & " (Titles) - Top].[" & z & "];"
0339 Set rsTableControl3 = CurrentDb.OpenRecordset(strNextPageQuery)
0340 If rsTableControl3.EOF Then
0341 NextPage = ""
0342 NextPageID = ""
0343 Else
0344 rsTableControl3.MoveFirst
0345 NextPage = rsTableControl3.Fields(0)
0346 NextPage = Left(NextPage, InStr(NextPage, "<") - 1)
0347 NextPageID = rsTableControl3.Fields(1)
0348 If rsTableControl3.Fields(2) = 1 Then
0349 NextPageID = NextPageID
0350 Else
0351 NextPageID = "Top_" & NextPageID
0352 End If
0353 End If
0354 LeftLink = IIf(strFileSuffix_Previous = "", "Previous Page: None", "Previous Page: <a href=""" & strOutputFileShort & "_Top_" & strFileSuffix_Previous & ".htm"">" & strFileTitle_Previous & "</a>")
0355 LeftLen = IIf(strFileSuffix_Previous = "", Len("Previous Page: None"), Len("Previous Page: " & strFileTitle_Previous))
0356 RightLink = IIf(NextPage = "", "Next Page: None", "Next Page: <a href=""" & strOutputFileShort & "_" & NextPageID & ".htm"">" & NextPage & "</a>")
0357 RightLen = IIf(NextPage = "", Len("Next Page: None"), Len("Next Page: " & NextPage))
0358 If LeftLen > RightLen Then
0359 MaxLen = LeftLen
0360 Else
0361 MaxLen = RightLen
0362 End If
0363 MaxLen = 200 + 15 * MaxLen
0364 If MaxLen > 950 Then
0365 LeftPct = Round((LeftLen + 100 / 8) / (LeftLen + RightLen + 200 / 8) * 100, 0)
0366 RightPct = 100 - LeftPct
0367 MaxLen = 200 + (LeftLen + RightLen) * 8
0368 Else
0369 LeftPct = 50
0370 RightPct = 50
0371 End If
0372 LinkTable = "<center><TABLE class = ""Bridge"" WIDTH=" & MaxLen & "><tr><th colspan=2><a href=""" & strOutputFileShort & ".htm"">Top Jump Table</a></th></tr><tr><th WIDTH=""" & LeftPct & "%"">" & LeftLink & "</th><th WIDTH=""" & RightPct & "%"">" & RightLink & "</th></tr></TABLE></center>"
0373 strLine = strLine & LinkTable
0374 strFileSuffix_Previous = strLetter_Title2
0375 strFileTitle_Previous = rsTableToReadJump4.Fields(0)
0376 strFileTitle_Previous = Left(strFileTitle_Previous, InStr(strFileTitle_Previous, "<") - 1)
0377 End If
0378 tsJumpFile.WriteLine strLine
0379 rsTableControl2.MoveNext
0380 Loop
0381 ' ... Header
0382 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = ""Jump_Table_Titles"") And ((Website_Control.Section) = ""Header"")) ORDER BY Website_Control.Line;"
0383 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0384 rsTableControl2.MoveFirst
0385 Do While Not rsTableControl2.EOF
0386 strLine = rsTableControl2.Fields(0) & ""
0387 tsJumpFile.WriteLine strLine
0388 rsTableControl2.MoveNext
0389 Loop
0390 ' ... Rows
0391 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = ""Jump_Table_Titles"") And ((Website_Control.Section) = ""Rows"")) ORDER BY Website_Control.Line;"
0392 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0393 rsTableControl2.MoveFirst
0394 strQuery = strDataQuery & " (Titles)"
0395 strQuery = "SELECT [" & strQuery & "].Category, [" & strQuery & "].ID FROM [" & strQuery & "] WHERE ((([" & strQuery & "].Top_ID) = """ & strLetter_Title2 & """)) ORDER BY [" & strQuery & "].Category;"
0396 Set rsTableToReadLetters = CurrentDb.OpenRecordset(strQuery)
0397 If Not rsTableToReadLetters.EOF Then 'This is a fudge for "Music Music" (202_35) and maybe others.
0398 rsTableToReadLetters.MoveFirst
0399 strLetter = rsTableToReadLetters.Fields(1) 'Note: this is the internal ID of the field
0400 strLetter_Title = rsTableToReadLetters.Fields(0)
0401 End If
0402 Do While (Not rsTableControl2.EOF Or Not rsTableToReadLetters.EOF)
0403 If rsTableControl2.EOF Then
0404 rsTableControl2.MoveFirst
0405 End If
0406 strLine = rsTableControl2.Fields(0) & ""
0407 x = InStr(1, strLine, "**Column")
0408 If x > 0 Then
0409 If strLetter <> "" Then
0410 If strSplitTable = "No" Then
0411 If InStr(strLetter_Title, "<BR>") > 0 Then
0412 strLetter_Title_Short = Left(strLetter_Title, InStr(strLetter_Title, "<BR>") - 1)
0413 Else
0414 strLetter_Title_Short = strLetter_Title
0415 End If
0416 Y = "<A HREF=""#Section" & Replace(strLetter_Title_Short, " ", "_") & """>" & strLetter_Title & "</A>"
0417 Else
0418 If strControlBreakType2 = "2-Level" Then
0419 Y = "<A HREF=""" & strOutputFileShort & "_" & strLetter & ".htm"">" & strLetter_Title & "</A>"
0420 Else
0421 Y = "<A HREF=""" & strOutputFileShort & "_" & strLetter & ".htm"">" & strLetter_Title & "</A>"
0422 End If
0423 End If
0424 Else
0425 Y = "."
0426 End If
0427 strLine = Left(strLine, x - 1) & Y & Mid(strLine, x + 10, Len(strLine))
0428 If Not rsTableToReadLetters.EOF Then
0429 rsTableToReadLetters.MoveNext
0430 If Not rsTableToReadLetters.EOF Then
0431 strLetter = rsTableToReadLetters.Fields(1)
0432 strLetter_Title = rsTableToReadLetters.Fields(0)
0433 Else
0434 strLetter = ""
0435 End If
0436 End If
0437 tsJumpFile.WriteLine strLine
0438 Else
0439 tsJumpFile.WriteLine strLine
0440 End If
0441 rsTableControl2.MoveNext
0442 Loop
0443 ' ... Footer
0444 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = ""Jump_Table_Titles"") And ((Website_Control.Section) = ""Footer"")) ORDER BY Website_Control.Line;"
0445 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0446 rsTableControl2.MoveFirst
0447 Do While Not rsTableControl2.EOF
0448 strLine = rsTableControl2.Fields(0) & ""
0449 tsJumpFile.WriteLine strLine
0450 rsTableControl2.MoveNext
0451 Loop
0452 tsJumpFile.WriteLine "<center>"
0453 'Page Footer
0454 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;"
0455 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0456 rsTableControl2.MoveFirst
0457 Do While Not rsTableControl2.EOF
0458 Time_Stamp = rsTableControl2.Fields(0)
0459 OK = Replace_Timestamp(Time_Stamp)
0460 tsJumpFile.WriteLine Time_Stamp
0461 rsTableControl2.MoveNext
0462 Loop
0463 'Copy page to Transfer directory
0464 OK = CopyToTransfer(strFolder, strOutputFileShort & "_Top_" & strLetter_Title2 & ".htm")
0465 Set tsJumpFile = Nothing
0466 End If
0467 rsTableToReadJump4.MoveNext
0468 Loop
0469 End If
0470 End If
0471 End If
0472 Else
0473 OK = Replace_Timestamp(strLine)
0474 strLine_SavedHeader = strLine_SavedHeader & rsTableControl.Fields(0)
0475 tsTextFile.WriteLine strLine
0476 End If
0477 rsTableControl.MoveNext
0478Loop
0479DataRead:
0480'Read the data
0481Set rsTableToRead = CurrentDb.OpenRecordset(strDataQuery)
0482iIDCol = rsTableToRead.Fields.Count 'Log the last column number (which contains the record ID)
0483If Not rsTableToRead.EOF Then
0484 rsTableToRead.MoveFirst
0485 strControlBreak = Left(rsTableToRead.Fields(0) & "", 1)
0486 iTableColumns = rsTableToRead.Fields.Count
0487End If
0488'Force a control-break
0489strControlBreak_Last = "@"
0490strFileSuffix = ""
0491strFileTitle = ""
0492If strSplitTable = "No" Then 'This is for tables that don't split across web-pages, so have intermediate control breaks
0493 'Read Table-Control for rows
0494 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;"
0495 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0496 If strControlBreakType = "xInitial" Then 'This has been disabled ... remove if proved not to be needed
0497 'Table Column Headings
0498 rsTableControl.MoveFirst
0499 Do While Not rsTableControl.EOF
0500 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0501 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0502 If iFieldNo > 0 And iFieldNo <= iTableColumns Then
0503 tsTextFile.WriteLine "<strong> " & rsTableToRead.Fields(iFieldNo - 1).Name & "</strong>"
0504 End If
0505 Else
0506 tsTextFile.WriteLine rsTableControl.Fields(0) & ""
0507 End If
0508 rsTableControl.MoveNext
0509 Loop
0510 End If
0511End If
0512z = rsTableToRead.Fields(0).Name
0513If Not rsTableToRead.EOF Then
0514 z1 = rsTableToRead.Fields(iTableColumns - 2).Name
0515End If
0516Do Until rsTableToRead.EOF
0517 strFileSuffix_Previous = strFileSuffix
0518 strFileTitle_Previous = strFileTitle
0519 If strControlBreakType2 = "BB" Then
0520 strFileSuffix = "_" & rsTableToRead.Fields(2) & ""
0521 Else
0522 If strSplitTable = "No" Then
0523 strFileSuffix = ""
0524 Else
0525 If strControlBreakType = "Initial" Then
0526 strFileSuffix = "_" & UCase(Left(rsTableToRead.Fields(0) & "", 1))
0527 Else
0528 strFileSuffix = "_" & rsTableToRead.Fields(iTableColumns - 2) & ""
0529 strFileTitle = rsTableToRead.Fields(0) & ""
0530 End If
0531 End If
0532 End If
0533 If strFileSuffix_Previous <> strFileSuffix Then
0534 'Write the previous Footer
0535 If strFileSuffix_Previous <> "" Then
0536 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;"
0537 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0538 rsTableControl.MoveFirst
0539 Do While Not rsTableControl.EOF
0540 Time_Stamp = rsTableControl.Fields(0) & ""
0541 OK = Replace_Timestamp(Time_Stamp)
0542 tsTextFile.WriteLine Time_Stamp
0543 rsTableControl.MoveNext
0544 Loop
0545 OK = CopyToTransfer(strFolder, strOutputFileShort & strFileSuffix_Previous & ".htm")
0546 End If
0547 'Create File
0548 Set tsTextFile = fsoTextFile.CreateTextFile(strOutputFile & strFileSuffix & ".htm", True, True)
0549 'Page Header
0550 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;"
0551 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0552 rsTableControl.MoveFirst
0553 Do While Not rsTableControl.EOF
0554 strLine = rsTableControl.Fields(0) & ""
0555 x = InStr(1, strLine, "**TITLE_HEAD**")
0556 If x > 0 Then
0557 If strControlBreakType2 = "BB" Then
0558 strLine = Left(strLine, x - 1) & "Section: " & rsTableToRead.Fields(3) & " - " & Mid(strLine, x + 14, Len(strLine))
0559 Else
0560 If strSplitTable = "No" Then
0561 strLine = Left(strLine, x - 1) & Mid(strLine, x + 15, Len(strLine))
0562 Else
0563 If strControlBreakType = "Initial" Then
0564 strLine = Left(strLine, x - 1) & "Section: " & Right(strFileSuffix, 1) & " - " & Mid(strLine, x + 14, Len(strLine))
0565 Else
0566 strLine = Left(strLine, x - 1) & "Section: " & rsTableToRead.Fields(0) & " - " & Mid(strLine, x + 14, Len(strLine))
0567 End If
0568 End If
0569 End If
0570 End If
0571 x = InStr(1, strLine, "**SECTION**")
0572 If x > 0 Then
0573 If strControlBreakType2 = "BB" Then
0574 strLine = Left(strLine, x - 1) & rsTableToRead.Fields(3) & Mid(strLine, x + 11, Len(strLine))
0575 Else
0576 If strSplitTable = "No" Then
0577 strLine = Left(strLine, x - 1) & "A-Z" & Mid(strLine, x + 11, Len(strLine))
0578 Else
0579 If strControlBreakType = "Initial" Then
0580 strLine = Left(strLine, x - 1) & Right(strFileSuffix, 1) & Mid(strLine, x + 11, Len(strLine))
0581 'Find Next page
0582 strNextPageQuery = "SELECT [" & strDataQuery & " (Letters)].* FROM [" & strDataQuery & " (Letters)];"
0583 Set rsTableControl3 = CurrentDb.OpenRecordset(strNextPageQuery)
0584 rsTableControl3.MoveFirst
0585 z = rsTableControl3.Fields(0).Name
0586 strNextPageQuery = "SELECT [" & strDataQuery & " (Letters)].[" & z & "] FROM [" & strDataQuery & " (Letters)] WHERE ((([" & strDataQuery & " (Letters)].[" & z & "])>""" & rsTableToRead.Fields(0).Value & """)) ORDER BY [" & strDataQuery & " (Letters)].[" & z & "];"
0587 Set rsTableControl3 = CurrentDb.OpenRecordset(strNextPageQuery)
0588 If rsTableControl3.EOF Then
0589 NextPage = ""
0590 NextPageID = ""
0591 Else
0592 rsTableControl3.MoveFirst
0593 NextPage = rsTableControl3.Fields(0)
0594 End If
0595 LeftLink = IIf(strFileSuffix_Previous = "", "Previous Page: None", "Previous Page: <a href=""" & strOutputFileShort & strFileSuffix_Previous & ".htm"">" & Right(strFileSuffix_Previous, 1) & "</a>")
0596 RightLink = IIf(NextPage = "", "Next Page: None", "Next Page: <a href=""" & strOutputFileShort & "_" & NextPage & ".htm"">" & NextPage & "</a>")
0597 LinkTable = "<center><TABLE class = ""Bridge"" WIDTH=600><tr><th colspan=2><a href=""" & strOutputFileShort & ".htm"">Top Jump Table</a></th></tr><tr><th WIDTH=""50%"">" & LeftLink & "</th><th WIDTH=""50%"">" & RightLink & "</th></tr></TABLE></center>"
0598 strLine = strLine & LinkTable
0599 Else
0600 strLine = Left(strLine, x - 1) & ": " & rsTableToRead.Fields(0) & Mid(strLine, x + 11, Len(strLine))
0601 'Find Next page
0602 strNextPageQuery = "SELECT [" & strDataQuery & "].[" & z & "], [" & strDataQuery & "].[" & z1 & "] FROM [" & strDataQuery & "] WHERE ((([" & strDataQuery & "].[" & z & "])>""" & rsTableToRead.Fields(0).Value & """)) ORDER BY [" & strDataQuery & "].[" & z & "];"
0603 Set rsTableControl3 = CurrentDb.OpenRecordset(strNextPageQuery)
0604 If rsTableControl3.EOF Then
0605 NextPage = ""
0606 NextPageID = ""
0607 Else
0608 rsTableControl3.MoveFirst
0609 NextPage = rsTableControl3.Fields(0)
0610 NextPageID = rsTableControl3.Fields(1)
0611 End If
0612 LeftLink = IIf(strFileSuffix_Previous = "", "Previous Page: None", "Previous Page: <a href=""" & strOutputFileShort & strFileSuffix_Previous & ".htm"">" & strFileTitle_Previous & "</a>")
0613 LeftLen = IIf(strFileSuffix_Previous = "", Len("Previous Page: None"), Len("Previous Page: " & strFileTitle_Previous))
0614 RightLink = IIf(NextPage = "", "Next Page: None", "Next Page: <a href=""" & strOutputFileShort & "_" & NextPageID & ".htm"">" & NextPage & "</a>")
0615 RightLen = IIf(NextPage = "", Len("Next Page: None"), Len("Next Page: " & NextPage))
0616 If LeftLen > RightLen Then
0617 MaxLen = LeftLen
0618 Else
0619 MaxLen = RightLen
0620 End If
0621 MaxLen = 200 + 15 * MaxLen
0622 If MaxLen > 950 Then
0623 LeftPct = Round((LeftLen + 100 / 8) / (LeftLen + RightLen + 200 / 8) * 100, 0)
0624 RightPct = 100 - LeftPct
0625 MaxLen = 200 + (LeftLen + RightLen) * 8
0626 Else
0627 LeftPct = 50
0628 RightPct = 50
0629 End If
0630 'Find next level up (if there is one)
0631 If InStr(2, strFileSuffix, "_") > 0 Then
0632 If InStr(rsTableToRead.Fields(0), " - ") > 0 Then
0633 Toplink = "<tr><th colspan=2>Next Level Up: <a href=""" & strOutputFileShort & "_Top" & Left(strFileSuffix, InStr(2, strFileSuffix, "_") - 1) & ".htm"">" & Left(rsTableToRead.Fields(0), InStr(rsTableToRead.Fields(0), " - ") - 1) & "</a></th></tr>"
0634 Else
0635 Toplink = "<tr><th colspan=2>Next Level Up: <a href=""" & strOutputFileShort & "_Top" & Left(strFileSuffix, InStr(2, strFileSuffix, "_") - 1) & ".htm"">" & rsTableToRead.Fields(0) & "</a></th></tr>"
0636 End If
0637 'Check for solitons
0638 On Error Resume Next
0639 strNextPageQuery = "SELECT [" & strDataQuery & " (Titles) - Solitons].[ID] FROM [" & strDataQuery & " (Titles) - Solitons] WHERE ((([" & strDataQuery & " (Titles) - Solitons].[ID])=""" & Mid(strFileSuffix, 2, 100) & """));"
0640 Set rsTableControl3 = CurrentDb.OpenRecordset(strNextPageQuery)
0641 If rsTableControl3.EOF Then
0642 Else
0643 Toplink = ""
0644 End If
0645 On Error GoTo 0
0646 Else
0647 Toplink = ""
0648 End If
0649 LinkTable = "<center><TABLE class = ""Bridge"" WIDTH=" & MaxLen & "><tr><th colspan=2><a href=""" & strOutputFileShort & ".htm"">Top Jump Table</a></th></tr>" & Toplink & "<tr><th WIDTH=""" & LeftPct & "%"">" & LeftLink & "</th><th WIDTH=""" & RightPct & "%"">" & RightLink & "</th></tr></TABLE></center>"
0650 strLine = strLine & LinkTable
0651 End If
0652 End If
0653 End If
0654 End If
0655 tsTextFile.WriteLine strLine
0656 rsTableControl.MoveNext
0657 Loop
0658 'Read Table-Control for rows
0659 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;"
0660 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0661 If strControlBreakType2 = "BB" Then
0662 'Write out the 2nd Jump List
0663 strControlQuery = "SELECT [" & strDataQuery & " (Breaks)].Break FROM [" & strDataQuery & " (Breaks)] WHERE ((([" & strDataQuery & " (Breaks)].Suffix)=""" & Mid(strFileSuffix, 2, Len(strFileSuffix)) & """));"
0664 Set rsTableControl_BB = CurrentDb.OpenRecordset(strControlQuery)
0665 If Not rsTableControl_BB.EOF Then
0666 rsTableControl_BB.MoveFirst
0667 Do While Not rsTableControl_BB.EOF
0668 tsTextFile.WriteLine "<A HREF=""#" & rsTableControl_BB.Fields(0) & """>" & rsTableControl_BB.Fields(0) & "</A><BR>"
0669 rsTableControl_BB.MoveNext
0670 Loop
0671 tsTextFile.WriteLine "<BR><BR><HR>"
0672 strCol1Break_Last = ""
0673 i = 1
0674 tsTextFile.WriteLine "<P ALIGN=""Left""><FONT Size = 2 FACE=""Arial"">"
0675 End If
0676 Else
0677 'Table Column Headings
0678 rsTableControl.MoveFirst
0679 Do While Not rsTableControl.EOF
0680 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0681 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0682 If iFieldNo > 0 And iFieldNo <= iTableColumns Then
0683 tsTextFile.WriteLine "<B> " & rsTableToRead.Fields(iFieldNo - 1).Name & "</B>"
0684 End If
0685 Else
0686 tsTextFile.WriteLine rsTableControl.Fields(0) & ""
0687 End If
0688 rsTableControl.MoveNext
0689 Loop
0690 End If
0691 End If
0692 'Internal Control Breaks
0693 If strControlBreakType = "Initial" Then
0694 strControlBreak = Left(rsTableToRead.Fields(0), 1)
0695 Else
0696 strControlBreak = Replace(rsTableToRead.Fields(0) & "", " ", "_")
0697 End If
0698 If strControlBreak_Last <> strControlBreak Then
0699 If strSplitTable = "No" Then
0700 'Add an internal table break + reference
0701 tsTextFile.WriteLine "</TABLE><a name=""Section" & Replace(strControlBreak, " ", "_") & """></a><h3>SECTION: " & Replace(strControlBreak, "_", " ") & "</h3><TABLE class = ""ReadingList"" WIDTH=950>"
0702 'Table Column Headings
0703 rsTableControl.MoveFirst
0704 Do While Not rsTableControl.EOF
0705 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0706 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0707 If iFieldNo > 0 And iFieldNo <= iTableColumns Then
0708 tsTextFile.WriteLine "<B> " & rsTableToRead.Fields(iFieldNo - 1).Name & "</B>"
0709 End If
0710 Else
0711 tsTextFile.WriteLine rsTableControl.Fields(0) & ""
0712 End If
0713 rsTableControl.MoveNext
0714 Loop
0715 End If
0716 strControlBreak_Last = strControlBreak
0717 End If
0718 'Table Row
0719 rsTableControl.MoveFirst
0720 Do While Not rsTableControl.EOF
0721 If Left(rsTableControl.Fields(0), 8) = "**Column" Then
0722 If strControlBreakType2 = "BB" Then
0723 strCol1Break = rsTableToRead.Fields(0)
0724 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0725 If iFieldNo > 0 And iFieldNo <= iTableColumns Then
0726 If iFieldNo = 1 Then
0727 If strCol1Break <> strCol1Break_Last Then
0728 strLine = "<A NAME=""" & strCol1Break & """></A><BR><B><U>" & strCol1Break & "</U></B><BR>"
0729 tsTextFile.WriteLine strLine
0730 i = 1
0731 End If
0732 Else
0733 If Left(strControlTable, 4) = "Book" Then
0734 strLine = i & ". " & rsTableToRead.Fields(iFieldNo - 1) & IIf(iFieldNo < iTableColumns, IIf(rsTableToRead.Fields(iTableColumns - 1) > 0, " (<A HREF = ""../../BookSummaries/BookSummary_" & Right(Str(Int(rsTableToRead.Fields(iTableColumns - 1) / 1000) + 1000000), 2) & "/BookSummary_" & rsTableToRead.Fields(iIDCol - 1) & ".htm"">More</A>)", ""), "") & "<BR>"
0735 Else
0736 strLine = i & ". " & rsTableToRead.Fields(iFieldNo - 1) & IIf(iFieldNo < iTableColumns, IIf(rsTableToRead.Fields(iTableColumns - 1) > 0, " (<A HREF = ""../Abstracts/Abstract_" & Right(Str(Int(rsTableToRead.Fields(iTableColumns - 1) / 1000) + 1000000), 2) & "/Abstract_" & rsTableToRead.Fields(iTableColumns - 1) & ".htm"">Abstract</A>)", ""), "") & " ... <A HREF = ""../PaperSummaries/PaperSummary_" & Right(Str(Int(rsTableToRead.Fields(iTableColumns - 2) / 1000) + 1000000), 2) & "/PaperSummary_" & rsTableToRead.Fields(iIDCol - 2) & ".htm"">More</A><BR>"
0737 End If
0738 tsTextFile.WriteLine strLine
0739 End If
0740 End If
0741 Else
0742 iFieldNo = Val(Mid(rsTableControl.Fields(0), 9, 2))
0743 If iFieldNo > 0 And iFieldNo <= iTableColumns Then
0744 If Len(rsTableToRead.Fields(iFieldNo - 1) & "") = 0 Then
0745 tsTextFile.WriteLine "&nbsp;"
0746 Else
0747 If rsTableToRead.Fields(iFieldNo - 1).Name = "Abstract" Then
0748 'Generate Paper Sumary & Abstract Links
0749 strLine = PaperSumaryAbstract_Links(rsTableToRead.Fields(iFieldNo - 1).Value, rsTableToRead.Fields(iIDCol - 1))
0750 Else
0751 strLine = rsTableToRead.Fields(iFieldNo - 1)
0752 If rsTableToRead.Fields(iFieldNo - 1).Name = "Source" Then
0753 strLine = Remove_Dummy_Ref(strLine)
0754 strLine = WebEncode(strLine)
0755 OK = Reference_Books(strLine, "X", 0, 0, 0)
0756 OK = Reference_Papers(strLine, "X", 0, 0, 0)
0757 OK = Reference_Webrefs(strLine, "X", 0, 0)
0758 Else
0759 If rsTableToRead.Fields(iFieldNo - 1).Name = "Link" Then
0760 If strLine = "**Precis**" Then 'Comments that were null, or (most likely) contained part of the precis
0761 strLine = ""
0762 Else
0763 strLine = Replace(strLine, "../", "")
0764 End If
0765 strLine = Remove_Dummy_Ref(strLine)
0766 strLine = WebEncode(strLine)
0767 OK = Reference_Books(strLine, "X", 0, 0, 0)
0768 OK = Reference_Papers(strLine, "X", 0, 0, 0)
0769 OK = Reference_Notes(strLine, "X", 0, 0, 0)
0770 OK = Reference_Notes(strLine, "X", 0, 0, 0, "Abstract_Direct")
0771 OK = Reference_Webrefs(strLine, "X", 0, 0)
0772 strLine = NumberedBullets(strLine)
0773 strLine = Bullets(strLine)
0774 tsTextFile.WriteLine "<A HREF = ""PaperSummaries/PaperSummary_" & Mid(rsTableToRead.Fields(iTableColumns - 1) + 100000, 2, 2) & "/PaperSummary_" & rsTableToRead.Fields(iTableColumns - 1) & ".htm"">" & "Summary" & "</A>, <A HREF = ""Abstracts/Abstract_" & Mid(rsTableToRead.Fields(iTableColumns - 1) + 100000, 2, 2) & "/Abstract_" & rsTableToRead.Fields(iTableColumns - 1) & ".htm"">Abstract</A><br>"
0775 If Len(strLine) > 500 Then
0776 strLine = "Précis link too long - follow above link to Abstract"
0777 End If
0778 Else
0779 If rsTableToRead.Fields(iFieldNo - 1).Name = "Author" Then
0780 OK = Author_Reference_String(strLine, 0)
0781 End If
0782 End If
0783 End If
0784 End If
0785 strLine = Replace(strLine, Chr(13) & Chr(10), "<BR>")
0786 tsTextFile.WriteLine strLine
0787 End If
0788 End If
0789 End If
0790 Else
0791 tsTextFile.WriteLine rsTableControl.Fields(0) & ""
0792 End If
0793 rsTableControl.MoveNext
0794 Loop
0795 rsTableToRead.MoveNext
0796 strCol1Break_Last = strCol1Break
0797 i = i + 1
0798Loop
0799'Final Page Footer
0800 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;"
0801Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0802rsTableControl.MoveFirst
0803Do While Not rsTableControl.EOF
0804 Time_Stamp = rsTableControl.Fields(0) & ""
0805 OK = Replace_Timestamp(Time_Stamp)
0806 tsTextFile.WriteLine Time_Stamp
0807 rsTableControl.MoveNext
0808Loop
0809TheEnd:
0810'Copy page to Transfer directory
0811 OK = CopyToTransfer(strFolder, strFileName)
0812 OK = CopyToTransfer(strFolder, strOutputFileShort & strFileSuffix & ".htm")
0813'Clearout
0814Set tsTextFile = Nothing
0815Set fsoTextFile = Nothing
0816Set tsTextFile = Nothing
0817Set tsJumpFile2 = Nothing
0818Set tsJumpFile3 = Nothing
0819Set rsAbstractQuality = Nothing
0820Set rsTableToRead = Nothing
0821Set rsTableToReadLetters = Nothing
0822Set rsTableToReadJump2 = Nothing
0823Set rsTableToReadJump3 = Nothing
0824Set rsTableToReadJump4 = Nothing
0825Set rsTableControl = Nothing
0826Set rsTableControl2 = Nothing
0827Set rsTableControl3 = Nothing
0828Set rsTableControl_BB = Nothing
0829End Sub

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


Source Code of: Find_Master_Notes
Procedure Type: Public Sub
Module: General_Subroutines
Lines of Code: 49
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Find_Master_Notes()
0002Dim rsNotes As Recordset
0003Dim rsTopNotes As Recordset
0004Dim rsNextNote As Recordset
0005Dim strLine As String
0006Dim Master_Note As Long
0007Dim Master_Note_Found As String
0008'Read the Notes
0009 strLine = "SELECT Notes.ID, Notes.Master_Note FROM Notes ORDER BY Notes.ID;"
0010Set rsNotes = CurrentDb.OpenRecordset(strLine)
0011rsNotes.MoveFirst
0012'Initialise the output file
0013 strLine = "DELETE Master_Notes.* FROM Master_Notes;"
0014DoCmd.RunSQL (strLine)
0015 strLine = "SELECT Master_Notes.* FROM Master_Notes;"
0016Set rsTopNotes = CurrentDb.OpenRecordset(strLine)
0017'Determine the Master_Notes
0018Do While Not rsNotes.EOF
0019 'Is this already a Master Note?
0020 If rsNotes.Fields(1).Value & "" = "" Or rsNotes.Fields(1).Value = 0 Then
0021 Master_Note = rsNotes.Fields(0).Value 'This Note is it's own Master
0022 Else
0023 'Iterate to find the Master Note
0024 Master_Note_Found = "No"
0025 Master_Note = rsNotes.Fields(1) & ""
0026 'Need fix for Notes accidentall having themselves as a master Note.
0027 Do While Master_Note_Found = "No"
0028 strLine = "SELECT Notes.Master_Note FROM Notes WHERE (((Notes.ID) = " & Master_Note & ")) ORDER BY Notes.ID;"
0029 Set rsNextNote = CurrentDb.OpenRecordset(strLine)
0030 rsNextNote.MoveFirst
0031 If rsNextNote.Fields(0).Value & "" = "" Or rsNextNote.Fields(0).Value = 0 Then
0032 Master_Note_Found = "Yes"
0033 Else
0034 Master_Note = rsNextNote.Fields(0).Value
0035 End If
0036 Loop
0037 End If
0038 'Add to Master_Notes table
0039 rsTopNotes.AddNew
0040 rsTopNotes.Fields(0) = rsNotes.Fields(0).Value
0041 rsTopNotes.Fields(1) = Master_Note
0042 rsTopNotes.Update
0043 'Around we go
0044 rsNotes.MoveNext
0045Loop
0046Set rsNotes = Nothing
0047Set rsTopNotes = Nothing
0048Set rsNextNote = Nothing
0049End Sub

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


Source Code of: Import_Data
Procedure Type: Public Sub
Module: General_Subroutines
Lines of Code: 32
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Import_Data()
0002Dim rst As Recordset
0003Dim db As Database
0004Dim FromFileName As String
0005Dim ToFileName As String
0006Dim PathName As String
0007Dim fs As Object
0008Dim ExcelApp As Excel.Application
0009PathName = "C:\Theo's Files\Birkbeck\Philosophers_Index\"
0010Set db = CurrentDb
0011 Set rst = db.OpenRecordset("SELECT Import_Files.File_Name FROM Import_Files ORDER BY Import_Files.File_Name DESC;")
0012rst.MoveFirst
0013Set fs = CreateObject("Scripting.FileSystemObject")
0014Do While Not rst.EOF
0015 FromFileName = PathName & "Excel\" & rst.Fields(0) & ".xls"
0016 ToFileName = PathName & "Import\" & "PhilosophersIndex.xls"
0017 If Dir(ToFileName) <> "" Then
0018 Kill ToFileName
0019 End If
0020 fs.CopyFile FromFileName, ToFileName
0021 Set ExcelApp = Excel.Application
0022 ExcelApp.Workbooks.Open (ToFileName)
0023 DoCmd.OpenQuery ("Add_To_Philosophers_Index_Converted")
0024 ExcelApp.ActiveWorkbook.Save
0025 ExcelApp.ActiveWorkbook.Close
0026 ExcelApp.Workbooks.Close
0027 ExcelApp.Quit
0028 ExcelApp.Quit
0029 Set ExcelApp = Nothing
0030 rst.MoveNext
0031Loop
0032End Sub

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


Source Code of: JumpTableTitles
Procedure Type: Public Sub
Module: General_Subroutines
Lines of Code: 204
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub JumpTableTitles(Optional Run_Type)
0002Dim strControlQuery As String
0003Dim rsTableControl2 As Recordset
0004Dim rsTableToReadLetters As Recordset
0005Dim rsMasterNote As Recordset
0006Dim strLetter As String
0007Dim strLetter_Title As String
0008Dim strLine As String
0009Dim x As Integer
0010Dim Y As String
0011Dim fsoTextFile As FileSystemObject
0012Dim Title_Loc As Integer
0013Dim strQuery As String
0014Dim Note_Subdirectory As String
0015Dim i As Long
0016Dim Add_Colours As Boolean
0017Dim strColour
0018If IsMissing(Run_Type) Then
0019 Set fsoTextFile = New FileSystemObject
0020 Set tsTextFile = fsoTextFile.CreateTextFile(strOutputFile & ".htm", True, True)
0021End If
0022'Title-based jump table
0023' ... Header
0024 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;"
0025Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0026rsTableControl2.MoveFirst
0027Do While Not rsTableControl2.EOF
0028 strLine = rsTableControl2.Fields(0) & ""
0029 Title_Loc = InStr(strLine, "**TITLE**")
0030 If Title_Loc > 0 Then
0031 strLine = Left(strLine, Title_Loc - 1) & Notes_Group & Mid(strLine, Title_Loc + 9, Len(strLine))
0032 If Notes_Group_Narrative & "" <> "" Then
0033 strLine = strLine & "<p><b>Note-Group Purpose: </b>" & Notes_Group_Narrative & "</p>"
0034 End If
0035 strLine = strLine & "<p><a href=""#Colours"">Click here</a> for the explanation of the colouration in the table below. </p>"
0036 End If
0037 tsTextFile.WriteLine strLine
0038 rsTableControl2.MoveNext
0039Loop
0040Add_Colours = True 'This flag was for testing ... or maybe subsequent exclusions
0041' ... Rows
0042 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Rows"")) ORDER BY Website_Control.Line;"
0043Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0044rsTableControl2.MoveFirst
0045If Notes_Recent > 0 Then
0046 'This simple sum decoupled because of weird numeric overflow problems.
0047 i = -Notes_Recent
0048 i = i * 1000
0049 i = i + Last_Changed_Timestamp
0050 strQuery = strDataQuery & " (Titles)_All"
0051 strQuery = "SELECT [" & strQuery & "].Item_Title, [" & strQuery & "].ID, [" & strQuery & "].Note_Quality_Text, [" & strQuery & "].Note_Quality_Colour FROM [" & strQuery & "] WHERE ((([" & strQuery & "].Last_Changed) > " & i & ") AND (([" & strQuery & "].Note_Group) = " & Notes_Group_ID & ")) ORDER BY [" & strQuery & "].Item_Title;"
0052Else
0053 strQuery = strDataQuery & " (Titles)"
0054 strQuery = "SELECT [" & strQuery & "].Item_Title, [" & strQuery & "].ID, [" & strQuery & "].Note_Quality_Text, [" & strQuery & "].Note_Quality_Colour FROM [" & strQuery & "] WHERE ((([" & strQuery & "].Note_Group) = " & Notes_Group_ID & ")) ORDER BY [" & strQuery & "].Item_Title;"
0055End If
0056Set rsTableToReadLetters = CurrentDb.OpenRecordset(strQuery)
0057If Not rsTableToReadLetters.EOF Then
0058 rsTableToReadLetters.MoveFirst
0059End If
0060If Not rsTableToReadLetters.EOF Then
0061 strLetter = rsTableToReadLetters.Fields(1) 'Note: this is the internal ID of the field
0062 strLetter_Title = rsTableToReadLetters.Fields(0)
0063 If Notes_Recent > 0 Then
0064 'Find the Master-Note
0065 Set rsMasterNote = CurrentDb.OpenRecordset("SELECT Notes.Item_Title, Notes.Note_Group FROM Notes INNER JOIN Master_Notes ON Notes.ID = Master_Notes.Top_Master_Note WHERE (((Master_Notes.ID)=" & strLetter & "));")
0066 If Not rsMasterNote.EOF Then
0067 rsMasterNote.MoveFirst
0068 If rsMasterNote.Fields(1).Value = 5 Then 'For Blog, prefix the Master Note ...
0069 If strLetter_Title <> rsMasterNote.Fields(0).Value Then
0070 strLetter_Title = strLetter_Title & " (" & rsMasterNote.Fields(0).Value & ")"
0071 End If
0072 End If
0073 End If
0074 Set rsMasterNote = Nothing
0075 End If
0076 Do While (Not rsTableControl2.EOF Or Not rsTableToReadLetters.EOF)
0077 If rsTableControl2.EOF Then
0078 rsTableControl2.MoveFirst
0079 End If
0080 strLine = rsTableControl2.Fields(0) & ""
0081 strColour = ""
0082 If Add_Colours = True Then
0083 If InStr(strLine, " **Colour**") > 0 Then
0084 If Not rsTableToReadLetters.EOF Then
0085 strColour = rsTableToReadLetters.Fields(3) & ""
0086 If strColour <> "" Then
0087 strColour = " bgcolor=""#" & strColour & """"
0088 strLine = Replace(strLine, " **Colour**", strColour)
0089 strLetter_Title = "<span title=""" & rsTableToReadLetters.Fields(2) & """>" & strLetter_Title & "</span>" 'Need to add pop-up
0090 End If
0091 End If
0092 End If
0093 End If
0094 strLine = Replace(strLine, " **Colour**", strColour)
0095 x = InStr(1, strLine, "**Column")
0096 If x > 0 Then
0097 If strLetter <> "" Then
0098 If strSplitTable = "No" Then
0099 Y = "<A HREF=""#Section" & Replace(strLetter_Title, " ", "_") & """>" & strLetter_Title & "</A>"
0100 Else
0101 'For Notes links, need to get the right directory
0102 If strTargetFileShort = "Notes" Then
0103 If IIf(IsMissing(Run_Type), "", Run_Type) = "Concatenated" Then
0104 Else
0105 Note_Subdirectory = Find_New_Directory(strLetter)
0106 'Remove irrelevant rubbish for Documentation
0107 If Right(strOutputFile, 2) = "13" Then
0108 strLetter_Title = Replace(strLetter_Title, "Website Generator Documentation - ", "")
0109 End If
0110 Note_Subdirectory = "Notes_" & Note_Subdirectory & "/"
0111 End If
0112 End If
0113 If IIf(IsMissing(Run_Type), "", Run_Type) = "Concatenated" Then
0114 Y = "<A HREF=""#InternalHyperlink_Note_" & strLetter & """>" & strLetter_Title & "</A>"
0115 Else
0116 Y = "<A HREF=""" & Note_Subdirectory & strTargetFileShort & "_" & strLetter & ".htm"">" & strLetter_Title & "</A>"
0117 End If
0118 End If
0119 Else
0120 Y = "&nbsp;"
0121 End If
0122 strLine = Left(strLine, x - 1) & Y & Mid(strLine, x + 10, Len(strLine))
0123 If Not rsTableToReadLetters.EOF Then
0124 rsTableToReadLetters.MoveNext
0125 If Not rsTableToReadLetters.EOF Then
0126 strLetter = rsTableToReadLetters.Fields(1)
0127 strLetter_Title = rsTableToReadLetters.Fields(0)
0128 If Notes_Recent > 0 Then
0129 'Find the Master-Note
0130 Set rsMasterNote = CurrentDb.OpenRecordset("SELECT Notes.Item_Title, Notes.Note_Group FROM Notes INNER JOIN Master_Notes ON Notes.ID = Master_Notes.Top_Master_Note WHERE (((Master_Notes.ID)=" & strLetter & "));")
0131 If Not rsMasterNote.EOF Then
0132 rsMasterNote.MoveFirst
0133 If rsMasterNote.Fields(1).Value = 5 Then 'For Blog, prefix the Master Note ...
0134 If strLetter_Title <> rsMasterNote.Fields(0).Value Then
0135 strLetter_Title = strLetter_Title & " (" & rsMasterNote.Fields(0).Value & ")"
0136 End If
0137 End If
0138 End If
0139 Set rsMasterNote = Nothing
0140 End If
0141 Else
0142 strLetter = ""
0143 End If
0144 End If
0145 tsTextFile.WriteLine strLine
0146 Else
0147 tsTextFile.WriteLine strLine
0148 End If
0149 rsTableControl2.MoveNext
0150 Loop
0151End If
0152' ... Footer
0153 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;"
0154Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0155rsTableControl2.MoveFirst
0156Do While Not rsTableControl2.EOF
0157 strLine = rsTableControl2.Fields(0) & ""
0158 If InStr(strLine, "**ConcatenatedList**") > 0 Then
0159 Concatenated_List_Control = True
0160 Form_Concatenated_Notes_List
0161 strLine = strList
0162 End If
0163 tsTextFile.WriteLine strLine
0164 rsTableControl2.MoveNext
0165Loop
0166'Add the colour-code table
0167 strLine = "<a name=""Colours""></a><p><b>Note Qualities: </b> for an explanation of the colouration in the table above, see the table below! ""Note Quality"" is a new feature, is somewhat experimental, and subject to checking and refinement. </p>"
0168tsTextFile.WriteLine strLine
0169strLine = "<TABLE class=""BridgeColLeft"" WIDTH=750>"
0170tsTextFile.WriteLine strLine
0171 strControlQuery = "SELECT Note_Qualities.Note_Quality_Text, Note_Qualities.Note_Quality_Colour, Note_Quality_Explanation FROM Note_Qualities ORDER BY Note_Qualities.Note_Quality;"
0172Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0173rsTableControl2.MoveFirst
0174Do While Not rsTableControl2.EOF
0175 strLine = rsTableControl2.Fields(0) & ""
0176 strLine = "<tr><td width=""30%"" align=left bgcolor=""#" & rsTableControl2.Fields(1) & """>" & strLine & "</td>"
0177 tsTextFile.WriteLine strLine
0178 strLine = rsTableControl2.Fields(2) & ""
0179 strLine = "<td width=""70%"" align=left>" & strLine & "&nbsp;</td></tr>"
0180 tsTextFile.WriteLine strLine
0181 rsTableControl2.MoveNext
0182Loop
0183strLine = "</TABLE>"
0184tsTextFile.WriteLine strLine
0185'Extra Footer
0186If IsMissing(Run_Type) Then
0187 'Create the extra footer
0188 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Footer2"")) ORDER BY Website_Control.Line;"
0189 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0190 rsTableControl2.MoveFirst
0191 Do While Not rsTableControl2.EOF
0192 strLine = rsTableControl2.Fields(0) & ""
0193 OK = Replace_Timestamp(strLine)
0194 tsTextFile.WriteLine strLine
0195 rsTableControl2.MoveNext
0196 Loop
0197End If
0198If IsMissing(Run_Type) Then
0199 OK = CopyToTransfer(strFolder, strFileName)
0200 Set tsTextFile = Nothing
0201End If
0202Set rsTableControl2 = Nothing
0203Set rsTableToReadLetters = Nothing
0204End Sub

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


Source Code of: JumpTableTitles_Recent_Control
Procedure Type: Public Sub
Module: General_Subroutines
Lines of Code: 175
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub JumpTableTitles_Recent_Control()
0002Dim strControlQuery As String
0003Dim rsTableControl2 As Recordset
0004Dim rsTableToRead As Recordset
0005Dim rsPaperAbstracts As Recordset
0006Dim strLetter As String
0007Dim strLetter_Title As String
0008Dim strLine As String
0009Dim x As Integer
0010Dim Y As String
0011Dim fsoTextFile As FileSystemObject
0012Dim tsTextFile As TextStream
0013Dim Title_Loc As Integer
0014Dim strDirectory As String
0015Dim Record_Count As Integer
0016Dim Display_Group As String
0017 strControlQuery = "SELECT Note_Groups.ID, Note_Groups.Note_Group, Sum(IIf([Jump_Table?]=Yes,1,0)*IIf([Private?]=""No"",1,0)) AS Total, Sum(IIf((Now()-IIf([Temp_Note_Timestamp]=0,[Last_Changed]/1000,[Temp_Note_Timestamp]/1000))-7<0,1,0)) AS [7 Days], Sum(IIf((Now()-IIf([Temp_Note_Timestamp]=0,[Last_Changed]/1000,[Temp_Note_Timestamp]/1000))-14<0,1,0)) AS [14 Days], Sum(IIf((Now()-IIf([Temp_Note_Timestamp]=0,[Last_Changed]/1000,[Temp_Note_Timestamp]/1000))-28<0,1,0)) AS [28 Days], Note_Groups.[Active?] FROM Note_Groups LEFT JOIN Notes ON Note_Groups.ID = Notes.Note_Group WHERE (((Note_Groups.[Active?])=""Yes"")) GROUP BY Note_Groups.ID, Note_Groups.Note_Group, Note_Groups.[Active?] ORDER BY Note_Groups.Note_Group;"
0018Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0019For Notes_Recent = 0 To 4
0020 If Notes_Recent = 3 Then 'Don't bother with 3-week
0021 Else
0022 strControlTable = "Jump_Table_Titles_Notes"
0023 strOutputFileShort = "Notes_Jump_Changed_" & Notes_Recent * 7
0024 strFileName = strOutputFileShort & ".htm"
0025 strTargetFileShort = "Notes_Jump"
0026 strOutputRoot = TheoWebsiteRoot & "\Notes\"
0027 strFolder = strOutputRoot
0028 strOutputFile = strOutputRoot & strOutputFileShort
0029 strTargetFile = strOutputRoot & strTargetFileShort
0030 strSplitTable = "Yes"
0031 Set fsoTextFile = New FileSystemObject
0032 Set tsTextFile = fsoTextFile.CreateTextFile(strOutputFile & ".htm", True, True)
0033 ' ... Header
0034 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;"
0035 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0036 rsTableControl2.MoveFirst
0037 Do While Not rsTableControl2.EOF
0038 strLine = rsTableControl2.Fields(0) & ""
0039 Title_Loc = InStr(strLine, "**TITLE**")
0040 If Title_Loc > 0 Then
0041 strLine = Left(strLine, Title_Loc - 1) & IIf(Notes_Recent > 0, "Active Note Groups with Notes Updated in the last " & Notes_Recent * 7 & " days - ", "") & Mid(strLine, Title_Loc + 9, Len(strLine))
0042 End If
0043 tsTextFile.WriteLine strLine
0044 rsTableControl2.MoveNext
0045 Loop
0046 'Rows
0047 rsTableToRead.MoveFirst
0048 ' ... Rows
0049 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Rows"")) ORDER BY Website_Control.Line;"
0050 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0051 rsTableControl2.MoveFirst
0052 strLetter = rsTableToRead.Fields(0) 'Note: this is the internal ID of the Notes Group
0053 If rsTableToRead.Fields(0).Value = 10 Then
0054 strDirectory = "../Secure_Jen/"
0055 Else
0056 strDirectory = ""
0057 End If
0058 Record_Count = IIf(Notes_Recent = 0, rsTableToRead.Fields(2), IIf(Notes_Recent = 1, rsTableToRead.Fields(3), IIf(Notes_Recent = 2, rsTableToRead.Fields(4), rsTableToRead.Fields(5))))
0059 strLetter_Title = rsTableToRead.Fields(1) & " (" & Record_Count & ")"
0060 Do While (Not rsTableControl2.EOF Or Not rsTableToRead.EOF)
0061 If rsTableControl2.EOF Then
0062 rsTableControl2.MoveFirst
0063 End If
0064 strLine = rsTableControl2.Fields(0) & ""
0065 x = InStr(1, strLine, "**Column")
0066 If x > 0 Then
0067 Display_Group = "No"
0068 If Record_Count > 0 Or Notes_Recent = 0 Then
0069 Display_Group = "Yes"
0070 Else
0071 If rsTableToRead.EOF = True Then
0072 Display_Group = "Yes"
0073 Else
0074 If rsTableToRead.Fields(6) = "Yes" Then 'Active Notes Group
0075 Display_Group = "Yes"
0076 End If
0077 End If
0078 End If
0079 If strLetter <> "" Then
0080 Y = "<A HREF=""" & strDirectory & strTargetFileShort & "_" & strLetter & IIf(Notes_Recent > 0, "_Recent_" & Notes_Recent * 7, "") & ".htm"">" & strLetter_Title & "</A>"
0081 Else
0082 Y = "&nbsp;"
0083 End If
0084 strLine = Left(strLine, x - 1) & Y & Mid(strLine, x + 10, Len(strLine))
0085 If Not rsTableToRead.EOF Then
0086 rsTableToRead.MoveNext
0087 If Not rsTableToRead.EOF Then
0088 strLetter = rsTableToRead.Fields(0) 'Note: this is the internal ID of the Notes Group
0089 If rsTableToRead.Fields(0).Value = 10 Then
0090 strDirectory = "../Secure_Jen/"
0091 Else
0092 strDirectory = ""
0093 End If
0094 strLetter_Title = rsTableToRead.Fields(1) & " (" & IIf(Notes_Recent = 0, rsTableToRead.Fields(2), IIf(Notes_Recent = 1, rsTableToRead.Fields(3), IIf(Notes_Recent = 2, rsTableToRead.Fields(4), rsTableToRead.Fields(5)))) & ")"
0095 Else
0096 strLetter = ""
0097 End If
0098 End If
0099 Else
0100 Display_Group = "Yes"
0101 End If
0102 If Display_Group = "Yes" Then
0103 tsTextFile.WriteLine strLine
0104 rsTableControl2.MoveNext
0105 End If
0106 Loop
0107 ' ... Footer
0108 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;"
0109 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0110 rsTableControl2.MoveFirst
0111 Do While Not rsTableControl2.EOF
0112 strLine = rsTableControl2.Fields(0)
0113 If InStr(strLine, "**ConcatenatedList**") > 0 Then
0114 Concatenated_List_Control = False
0115 Form_Concatenated_Notes_List
0116 strLine = strList
0117 End If
0118 tsTextFile.WriteLine strLine
0119 rsTableControl2.MoveNext
0120 Loop
0121 If Notes_Recent > 0 Then
0122 'Add Changed Paper Abstracts
0123 strLine = "There follow lists of Papers and / or Books addressed or Abstracts Updated in the last " & Notes_Recent * 7 & " days. These lists are generated automatically from my database, and may not represent significant activity as they are triggered by any database change - eg. re-filing. <BR><BR>"
0124 tsTextFile.WriteLine strLine
0125 Set rsPaperAbstracts = CurrentDb.OpenRecordset("Select * From Abstracts_Recent Where Abstracts_Recent!Period <= " & Notes_Recent & ";")
0126 If Not rsPaperAbstracts.EOF Then
0127 rsPaperAbstracts.MoveFirst
0128 'Heading
0129 strLine = "<B><U>Papers addressed or Abstracts Updated in the last " & Notes_Recent * 7 & " days</B></U><UL TYPE=""DISC"">"
0130 tsTextFile.WriteLine strLine
0131 'Rows
0132 Do While Not rsPaperAbstracts.EOF
0133 strLine = "<LI><A HREF = ""../Abstracts/Abstract_" & Right(Int(rsPaperAbstracts.Fields(1) / 1000) + 100, 2) & "/Abstract_" & rsPaperAbstracts.Fields(1) & ".htm"">" & rsPaperAbstracts.Fields(0) & "</A></li>"
0134 tsTextFile.WriteLine strLine
0135 rsPaperAbstracts.MoveNext
0136 Loop
0137 strLine = "</UL><BR>"
0138 tsTextFile.WriteLine strLine
0139 End If
0140 'Add Changed Book Abstracts ... use rsPaperAbstracts recordset!
0141 Set rsPaperAbstracts = CurrentDb.OpenRecordset("Select * From Book_Abstracts_Recent Where Book_Abstracts_Recent!Period <= " & Notes_Recent & ";")
0142 If Not rsPaperAbstracts.EOF Then
0143 rsPaperAbstracts.MoveFirst
0144 'Heading
0145 strLine = "<B><U>Books addressed or Updated in the last " & Notes_Recent * 7 & " days</B></U><UL TYPE=""DISC"">"
0146 tsTextFile.WriteLine strLine
0147 'Rows
0148 Do While Not rsPaperAbstracts.EOF
0149 strLine = "<LI><A HREF = ""../BookSummaries/BookSummary_" & Right(Int(rsPaperAbstracts.Fields(1) / 1000) + 100, 2) & "/BookPaperAbstracts/BookPaperAbstracts_" & rsPaperAbstracts.Fields(1) & ".htm"">" & rsPaperAbstracts.Fields(0) & "</A></li>"
0150 tsTextFile.WriteLine strLine
0151 rsPaperAbstracts.MoveNext
0152 Loop
0153 strLine = "</UL><BR>"
0154 tsTextFile.WriteLine strLine
0155 End If
0156 End If
0157 'Create the extra footer
0158 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Footer2"")) ORDER BY Website_Control.Line;"
0159 Set rsTableControl2 = CurrentDb.OpenRecordset(strControlQuery)
0160 rsTableControl2.MoveFirst
0161 Do While Not rsTableControl2.EOF
0162 strLine = rsTableControl2.Fields(0) & ""
0163 OK = Replace_Timestamp(strLine)
0164 tsTextFile.WriteLine strLine
0165 rsTableControl2.MoveNext
0166 Loop
0167 'Copy to Transfer Drive
0168 OK = CopyToTransfer(strFolder, strFileName)
0169 End If
0170 Set rsPaperAbstracts = Nothing
0171Next Notes_Recent
0172Set rsTableControl2 = Nothing
0173Set rsTableToRead = Nothing
0174Set tsTextFile = Nothing
0175End Sub

Procedures Calling This Procedure (JumpTableTitles_Recent_Control) Procedures Called By This Procedure (JumpTableTitles_Recent_Control) Tables / Queries / Fragments Directly Used By This Procedure (JumpTableTitles_Recent_Control) 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