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 7 (4 items)

Classification_ChangeAdjustTheRangeCreateBookSummariesWebPagesCreateQueryWebpages

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

Go to top of page



Source Code of: AdjustTheRange
Procedure Type: Public Sub
Module: LazyLibrarian
Lines of Code: 19

Line-No. / Ref.Code Line
0001Public Sub AdjustTheRange()
0002'We aren't interested in "frozen" books at the edges since they can't move
0003If Volume(1) = 1 Then
0004 FirstVolGrabbed = "Yes"
0005End If
0006If FirstVolGrabbed = "Yes" Then
0007 Do While (Volume(MinPlace + 1) = MinPlace + 1) And MinPlace < Vols - 1
0008 MinPlace = MinPlace + 1
0009 Loop
0010End If
0011If Volume(Vols) = Vols Then
0012 LastVolGrabbed = "Yes"
0013End If
0014If LastVolGrabbed = "Yes" Then
0015 Do While (Volume(MaxPlace - 1) = MaxPlace - 1) And MaxPlace > 2
0016 MaxPlace = MaxPlace - 1
0017 Loop
0018End If
0019End Sub

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


Source Code of: Classification_Change
Procedure Type: Public Function
Module: Testing
Lines of Code: 34
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Classification_Change(strString)
0002Dim rsTableToRead As Recordset
0003Static Category_Conversion_Table(100, 2) As String
0004Dim i As Integer
0005Dim j As Integer
0006'Initialise Table
0007If Category_Conversion_Table(1, 1) = "" Then
0008 For i = 1 To 100
0009 For j = 1 To 2
0010 Category_Conversion_Table(i, j) = ""
0011 Next j
0012 Next i
0013 i = 1
0014 Set rsTableToRead = CurrentDb.OpenRecordset("Select * FROM Category_Change;")
0015 If Not rsTableToRead.EOF Then
0016 rsTableToRead.MoveFirst
0017 Do Until rsTableToRead.EOF
0018 If rsTableToRead.Fields(0) <> rsTableToRead.Fields(1) Then
0019 Category_Conversion_Table(i, 1) = rsTableToRead.Fields(0)
0020 Category_Conversion_Table(i, 2) = rsTableToRead.Fields(1)
0021 i = i + 1
0022 End If
0023 rsTableToRead.MoveNext
0024 Loop
0025 End If
0026End If
0027For i = 1 To 100
0028 If Category_Conversion_Table(i, 1) = "" Then
0029 i = 101
0030 Else
0031 strString = Replace(strString, Category_Conversion_Table(i, 1), Category_Conversion_Table(i, 2))
0032 End If
0033Next i
0034End Function

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


Source Code of: CreateBookSummariesWebPages
Procedure Type: Public Sub
Module: General_Subroutines
Lines of Code: 414
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub CreateBookSummariesWebPages(Optional NoMessages)
0002Dim fsoTextFile As FileSystemObject
0003Dim tsTextFile As TextStream
0004Dim rsTableToRead As Recordset
0005Dim rsTableToRead2 As Recordset
0006Dim rsTableControl As Recordset
0007Dim rsAuthors As Recordset
0008Dim rsActuals As Recordset
0009Dim rsSubject As Recordset
0010Dim strControlQuery As String
0011Dim strLine As String
0012Dim strText As String
0013Dim x As Long
0014Dim iCols As Integer
0015Dim iCol As Integer
0016Dim i As Integer
0017Dim iAbstractCol As Integer
0018Dim iCommentCol As Integer
0019Dim Bullet_Type As String
0020Dim StartTime As Date
0021Dim RunStartTime As Date
0022Dim Duration As Double
0023Dim Response As String
0024Dim strMessage As String
0025Dim Total_Run As Single
0026Dim Run_Type As String
0027Dim All_Done As Boolean
0028Dim RunDate As Date
0029Dim iCount As Long
0030Dim strFieldName As String
0031Dim strFieldValue As String
0032Dim strTop As String
0033Dim Field_Type As String
0034Dim qPages As Long
0035Dim TotalHrs As Single
0036Dim strNoMessages As String
0037Dim sw As StopWatch
0038Dim sw2 As StopWatch
0039If Test_Flag = True Then
0040 Set sw = New StopWatch
0041 Set sw2 = New StopWatch
0042End If
0043iCount = 0
0044If IsMissing(NoMessages) Then
0045 strNoMessages = "No"
0046Else
0047 strNoMessages = "Yes"
0048End If
0049Set fsoTextFile = New FileSystemObject
0050NoteBookLinksDB_Open = "Closed"
0051 DoCmd.OpenQuery ("Book_Summary_Temp_Zap")
0052If automatic_processing = "Yes" Then
0053 Run_Type = "Regen"
0054 Response = vbYes
0055 GoTo Automatic
0056End If
0057If strNoMessages = "Yes" Then
0058 Response = vbYes
0059Else
0060 Response = MsgBox("Do you want to regenerate pages for changed Book Summaries only?", vbYesNoCancel)
0061End If
0062Total_Run = 0
0063If Response = vbYes Then
0064 'Determine changed BookSummary records
0065 DoCmd.OpenQuery ("Book_Summary_Temp_GEN")
0066 Run_Type = "Changed"
0067Else
0068 If Response = vbCancel Then
0069 MsgBox ("Warning - by skipping the update to Book Summaries, you might miss some updates.")
0070 Exit Sub
0071 Else
0072 Run_Type = "Regen"
0073 If Response = vbNo Then
0074 Response = MsgBox("Do you want to regenerate Book Summaries for Books with IDs in particular ranges?", vbYesNoCancel)
0075 If Response = vbYes Then
0076 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM Book_Summary_Ranges WHERE [Select?] = True ORDER BY ID_Start;")
0077 If Not rsTableToRead.EOF Then
0078 rsTableToRead.MoveFirst
0079 strMessage = "Run for the following range" & IIf(rsTableToRead.RecordCount > 1, "s", "") & "?" & Chr(10) & Chr(10)
0080 Do While Not rsTableToRead.EOF
0081 strMessage = strMessage & rsTableToRead.Fields(0) & ": " & rsTableToRead.Fields(1) & "-" & rsTableToRead.Fields(2) & ": " & Round(rsTableToRead.Fields(5), 0) & " mins (" & Round(rsTableToRead.Fields(4), 0) & ", " & Round((Now() - Round(rsTableToRead.Fields(4))), 0) & " days)" & Chr(10)
0082 Total_Run = Total_Run + rsTableToRead.Fields(5)
0083 rsTableToRead.MoveNext
0084 Loop
0085 strMessage = strMessage & "Total time = " & Round(Total_Run, 0) & " mins." & Chr(10) & Chr(10)
0086 Else
0087 DoCmd.OpenTable ("Book_Summary_Ranges")
0088 MsgBox ("No Ranges selected. Update the Book_Abstract_Ranges Table.")
0089 End
0090 End If
0091 Total_Run = 0
0092 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM Book_Summary_Ranges WHERE [Select?] = False ORDER BY ID_Start;")
0093 If Not rsTableToRead.EOF Then
0094 strMessage = strMessage & "Not selected:- " & Chr(10) & Chr(10)
0095 rsTableToRead.MoveFirst
0096 Do While Not rsTableToRead.EOF
0097 strMessage = strMessage & rsTableToRead.Fields(0) & ": " & rsTableToRead.Fields(1) & "-" & rsTableToRead.Fields(2) & ": " & Round(rsTableToRead.Fields(5), 0) & " mins (" & Round(rsTableToRead.Fields(4), 0) & ", " & Round((Now() - Round(rsTableToRead.Fields(4))), 0) & " days)" & Chr(10)
0098 Total_Run = Total_Run + rsTableToRead.Fields(5)
0099 rsTableToRead.MoveNext
0100 Loop
0101 strMessage = strMessage & "Total time outstanding = " & Round(Total_Run, 0) & " mins." & Chr(10) & Chr(10)
0102 End If
0103 Response = MsgBox(strMessage, vbYesNo)
0104 If Response = vbNo Then
0105 DoCmd.OpenTable ("Book_Summary_Ranges")
0106 MsgBox ("Update the Book_Summary_Ranges Table.")
0107 End
0108 End If
0109 End If
0110 End If
0111 End If
0112End If
0113Automatic:
0114If Response <> vbYes Then
0115 Exit Sub
0116End If
0117If Run_Type = "Changed" Then
0118 'Read BookSummary records
0119 strControlQuery = "BookSummaries_Changed_List"
0120 Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0121 If rsTableToRead.EOF Then
0122 If automatic_processing <> "Yes" And strNoMessages = "No" Then
0123 MsgBox ("No changed BookSummaries!")
0124 End If
0125 Exit Sub
0126 Else
0127 rsTableToRead.MoveFirst
0128 'Determine the number of columns
0129 iCols = rsTableToRead.Fields.Count
0130 End If
0131Else
0132 Set rsTableToRead2 = CurrentDb.OpenRecordset("SELECT * FROM Book_Summary_Ranges WHERE [Select?] = True ORDER BY ID_Start;")
0133 If rsTableToRead2.EOF Then
0134 All_Done = True
0135 Else
0136 All_Done = False
0137 rsTableToRead2.MoveFirst
0138 End If
0139End If
0140'Output BookSummary Pages
0141StartTime = Now()
0142RunStartTime = Now()
0143All_Done = False
0144Do Until All_Done = True
0145 If Run_Type = "Changed" Then
0146 All_Done = True
0147 Else
0148 'Generate records list
0149 strControlQuery = "Select Current_ID.* FROM Current_ID; "
0150 Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery) 'Borrow this recordset!
0151 rsTableToRead.MoveFirst
0152 rsTableToRead.Edit
0153 rsTableToRead.Fields(0) = rsTableToRead2.Fields(0)
0154 rsTableToRead.Update
0155 DoCmd.OpenQuery ("Book_Summary_Temp_GEN_All") 'Creates the temporary table used by the folowing query
0156 strControlQuery = "BookSummaries_Changed_List"
0157 Set rsTableToRead = CurrentDb.OpenRecordset(strControlQuery)
0158 If Not rsTableToRead.EOF Then
0159 rsTableToRead.MoveFirst
0160 'Determine the number of columns
0161 iCols = rsTableToRead.Fields.Count
0162 End If
0163 End If
0164 'Determine the number of columns
0165 iCols = rsTableToRead.Fields.Count
0166 iCol = 3
0167 'Find where the Abstract and Comment columns are
0168 'Note: As the Abstract and comment are in the Book / Papers Abstracts Summary, I've removed them from this page, but left the code in ...
0169 iAbstractCol = 1
0170 iCommentCol = 1
0171 Do While iCol < iCols
0172 If rsTableToRead.Fields(iCol).Name = "Abstract" Then
0173 iAbstractCol = iCol
0174 End If
0175 If rsTableToRead.Fields(iCol).Name = "Comments" Then
0176 iCommentCol = iCol
0177 End If
0178 iCol = iCol + 1
0179 Loop
0180 'BookSummary Pages (but use PaperSummary control as it's the same)
0181 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = ""PaperSummary"") And ((Website_Control.Section) = ""Text"")) ORDER BY Website_Control.Line;"
0182 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0183 Do While Not rsTableToRead.EOF
0184 If Test_Flag = True Then
0185 sw.StartTimer
0186 End If
0187 strFolder = TheoWebsiteRoot & "\BookSummaries\BookSummary_" & Right(Str(Int(rsTableToRead.Fields(0) / 1000) + 1000000), 2) & "\"
0188 strFileName = "BookSummary_" & rsTableToRead.Fields(0) & ".htm"
0189 Set tsTextFile = fsoTextFile.CreateTextFile(strFolder & strFileName, True, True)
0190 rsTableControl.MoveFirst
0191 Do While Not rsTableControl.EOF
0192 strLine = rsTableControl.Fields(0) & ""
0193 x = InStr(1, strLine, "**HEAD_TITLE**")
0194 strLine = Replace(strLine, "**BOOKPAPER**", "Book")
0195 If x > 0 Then
0196 strLine = Left(strLine, x - 1) & rsTableToRead.Fields(2) & " (" & rsTableToRead.Fields(1) & ") - Book Summary (Theo Todman's Web Page)" & Mid(strLine, x + 14, Len(strLine))
0197 End If
0198 x = InStr(1, strLine, "**Author**")
0199 If x > 0 Then
0200 strLine = Left(strLine, x - 1) & rsTableToRead.Fields(1) & Mid(strLine, x + 10, Len(strLine))
0201 End If
0202 x = InStr(1, strLine, "**Title**")
0203 If x > 0 Then
0204 strLine = Left(strLine, x - 1) & rsTableToRead.Fields(2) & Mid(strLine, x + 9, Len(strLine))
0205 End If
0206 OK = Replace_Timestamp(strLine)
0207 x = InStr(1, strLine, "**TEXT**")
0208 If x > 0 Then
0209 Clear_Colour_Usage
0210 'Set the bullet-type (used to have a consistency-check: dropped now I don't show Comments or Abstracts in the BookSummaries page
0211 Bullet_Type = "</UL>"
0212 strText = "<UL>"
0213 strText = "|Colour_1|" & strText
0214 'Output Author-Link Pages
0215 strControlQuery = "SELECT Author_Book_Links.Author FROM Author_Book_Links WHERE (((Author_Book_Links.Book_ID1) = " & rsTableToRead.Fields(0) & ")) ORDER BY Author_Book_Links.Author;"
0216 Set rsAuthors = CurrentDb.OpenRecordset(strControlQuery)
0217 If Not rsAuthors.EOF Then
0218 rsAuthors.MoveFirst
0219 Do While Not rsAuthors.EOF
0220 strText = strText & "<LI><B>" & rsAuthors.Fields(0).Name & "</B>: <A HREF = ""../../Authors/" & Left(rsAuthors.Fields(0).Value, 1) & "/Author_" & rsAuthors.Fields(0).Value & ".htm"">" & rsAuthors.Fields(0).Value & "</A></li>"
0221 rsAuthors.MoveNext
0222 Loop
0223 End If
0224 'Output non-empty table columns
0225 iCol = 3
0226 qPages = 10000
0227 Do While iCol < iCols
0228 If rsTableToRead.Fields(iCol).Name = "Total Actual Hours" Then
0229 Set rsActuals = CurrentDb.OpenRecordset("SELECT ""Actual Hours "" & [Year] & ""/"" & Right([Year]+1,2) AS Period, Sum(Paper_Actuals.Hours) AS SumOfHours FROM ((Books INNER JOIN qryBooks ON Books.ID1 = qryBooks.ID1) INNER JOIN Papers ON qryBooks.IDs = Papers.Book) INNER JOIN Paper_Actuals ON Papers.ID = Paper_Actuals.ID WHERE (((Books.ID1) = " & rsTableToRead.Fields(0).Value & ")) GROUP BY ""Actual Hours "" & [Year] & ""/"" & Right([Year]+1,2) HAVING (((Sum(Paper_Actuals.Hours))>0)) ORDER BY ""Actual Hours "" & [Year] & ""/"" & Right([Year]+1,2);")
0230 If Not rsActuals.EOF Then
0231 strText = strText & "<OL>"
0232 Do While Not rsActuals.EOF
0233 strText = strText & "<LI><B>" & rsActuals.Fields(0).Value & "</B>: " & Round(rsActuals.Fields(1).Value, 2) & "</li>"
0234 rsActuals.MoveNext
0235 Loop
0236 strText = strText & "</OL>"
0237 End If
0238 TotalHrs = Round(rsTableToRead.Fields(iCol).Value, 2)
0239 strText = strText & "<LI><B>" & rsTableToRead.Fields(iCol).Name & "</B>: " & TotalHrs & "</li>"
0240 Else
0241 If rsTableToRead.Fields(iCol).Value & "" <> "" Then
0242 strFieldName = rsTableToRead.Fields(iCol).Name
0243 strFieldValue = rsTableToRead.Fields(iCol).Value
0244 If strFieldName = "Read" Then
0245 If TotalHrs < qPages / 50 Then
0246 strFieldValue = strFieldValue & " (<a href=""../../Notes/Notes_13/Notes_1315.htm"">See this Note re Total Actual Hours</a>)"
0247 End If
0248 End If
0249 If strFieldName = "Pages" Then
0250 qPages = strFieldValue
0251 End If
0252 If InStr(strFieldName, "Subject") > 0 Then
0253 strControlQuery = "SELECT Subjects.* FROM Subjects WHERE Subjects.Subject = """ & strFieldValue & """;"
0254 Set rsSubject = CurrentDb.OpenRecordset(strControlQuery)
0255 If Not rsSubject.EOF Then
0256 rsSubject.MoveFirst
0257 Field_Type = rsSubject.Fields(3)
0258 If Field_Type = "None" Then
0259 Else
0260 If Field_Type = "Top" Then
0261 strTop = "Top_"
0262 Else
0263 strTop = ""
0264 End If
0265 strFieldValue = "<a href=""../../BookCatalogCategorised_" & strTop & rsSubject.Fields(0) & ".htm"">" & strFieldValue & "</a>"
0266 End If
0267 End If
0268 Else
0269 If InStr(strFieldName, "Sub-Topic") > 0 Then
0270 strControlQuery = "SELECT [Sub-Topics].* FROM [Sub-Topics] WHERE [Sub-Topics].[Sub-Topic] = """ & strFieldValue & """;"
0271 Set rsSubject = CurrentDb.OpenRecordset(strControlQuery)
0272 If Not rsSubject.EOF Then
0273 rsSubject.MoveFirst
0274 Field_Type = rsSubject.Fields(4)
0275 If Field_Type = "None" Then
0276 Else
0277 strFieldValue = "<a href=""../../PaperCatalogPhilosophyFullCategorisedSubTopic_" & rsSubject.Fields(0) & ".htm"">" & strFieldValue & "</a>"
0278 End If
0279 End If
0280 Set rsSubject = Nothing
0281 Else
0282 If InStr(strFieldName, "Topic") > 0 Then
0283 If strFieldValue <> "Identity" Then
0284 strControlQuery = "SELECT [Topics].* FROM [Topics] WHERE [Topics].[Topic] = """ & strFieldValue & """;"
0285 Set rsSubject = CurrentDb.OpenRecordset(strControlQuery)
0286 If Not rsSubject.EOF Then
0287 rsSubject.MoveFirst
0288 Field_Type = rsSubject.Fields(3)
0289 If Field_Type = "None" Then
0290 Else
0291 strFieldValue = "<a href=""../../PaperCatalogPhilosophyFullCategorised_Top_" & rsSubject.Fields(0) & ".htm"">" & strFieldValue & "</a>"
0292 End If
0293 End If
0294 Set rsSubject = Nothing
0295 Else
0296 strFieldValue = "<a href=""../../PaperCatalogIdentityFull.htm"">" & strFieldValue & "</a>"
0297 End If
0298 End If
0299 End If
0300 End If
0301 strText = strText & "<LI><B>" & strFieldName & "</B>: " & strFieldValue & "</li>"
0302 End If
0303 End If
0304 iCol = iCol + 1
0305 Loop
0306 'Output Citing-Link Pages
0307 If Test_Flag = True Then
0308 sw2.StartTimer
0309 End If
0310 strControlQuery = "SELECT Book_Citings_List_New.* FROM Book_Citings_List_New WHERE Book_Citings_List_New.Book_ID = " & rsTableToRead.Fields(0) & ";"
0311 Set rsAuthors = CurrentDb.OpenRecordset(strControlQuery) 'Use dummy recordset
0312 If Not rsAuthors.EOF Then
0313 rsAuthors.MoveFirst
0314 strText = strText & "<LI><B>Books / Papers Citing this Book</B>: <A HREF = ""BookCitings_" & rsTableToRead.Fields(0) & ".htm"">Follow Link</A></li>"
0315 End If
0316 If Test_Flag = True Then
0317 Debug.Print Now(); strFileName; sw2.EndTimer; "Milliseconds"; " Books / Papers Citing this Book"
0318 End If
0319 'Add Author Citings
0320 strControlQuery = "SELECT Authors.Author_Name FROM Authors INNER JOIN Cross_Reference ON Authors.Author_ID = Cross_Reference.Calling_ID WHERE (((Cross_Reference.Called_ID) = " & rsTableToRead.Fields(0) & ") And ((Cross_Reference.Calling_Type) = ""A"") And ((Cross_Reference.Called_Type) = ""B"")) ORDER BY Authors.Author_Name;"
0321 Set rsActuals = CurrentDb.OpenRecordset(strControlQuery) 'Use dummy recordset
0322 If Not rsActuals.EOF Then
0323 rsActuals.MoveFirst
0324 strText = strText & "<LI><B>Authors Citing this Book</B>: "
0325 strText = strText & "<A HREF = ""../../Authors/" & Left(rsActuals.Fields(0), 1) & "/Author_" & rsActuals.Fields(0) & ".htm"">" & rsActuals.Fields(0) & "</A>"
0326 rsActuals.MoveNext
0327 Do While Not rsActuals.EOF
0328 strText = strText & ", <A HREF = ""../../Authors/" & Left(rsActuals.Fields(0), 1) & "/Author_" & rsActuals.Fields(0) & ".htm"">" & rsActuals.Fields(0) & "</A>"
0329 rsActuals.MoveNext
0330 Loop
0331 Set rsActuals = Nothing
0332 End If
0333 'Tidy Up
0334 strText = strText & Bullet_Type
0335 strLine = Left(strLine, x - 1) & strText & Mid(strLine, x + 8, Len(strLine))
0336 strLine = ReplaceCode(strLine, Chr(13) & Chr(10), "<BR>")
0337 OK = Reference_FootNotes("B", rsTableToRead.Fields(0), strLine)
0338 'Translate web references & links
0339 strLine = Remove_Dummy_Ref(strLine)
0340 strLine = WebEncode(strLine)
0341 strLine = NumberedBullets(strLine) 'Add Numbered Bullets
0342 strLine = Bullets(strLine) 'Add Un-Numbered Bullets
0343 OK = Reference_Notes(strLine, "X", 0, 0, 2, "Abstract", "Book", rsTableToRead.Fields(0)) 'Replace the Notes References by hyperlinks
0344 OK = Reference_Notes(strLine, "X", 0, 0, 2, "Not Abstract", "Book", rsTableToRead.Fields(0)) 'Replace the Notes References by hyperlinks
0345 OK = Reference_Papers(strLine, "X", 0, 0) 'Replace the Papers References by hyperlinks
0346 OK = Reference_Author(strLine, "X", 0, 0) 'Replace the Author References by hyperlinks
0347 OK = Reference_Books(strLine, "X", 0, 0) 'Replace the Books References by hyperlinks
0348 OK = Reference_Webrefs(strLine, "X", 0, 0)
0349 If InStr(strLine, "|Colour_2") > 0 Then 'Only show Colour Conventions if there's some "correspondent" text (which there won't be ...)
0350 OK = Mark_Colours(strLine)
0351 strLine = strLine & "<hr><B><U>Text Colour Conventions</U></B><OL TYPE=""1"">"
0352 For i = 0 To 19
0353 If Colour_Table(i, 4) = "1" Then
0354 strLine = strLine & "<LI><FONT COLOR = """ & Colour_Table(i, 1) & """>" & Colour_Table(i, 2) & "</FONT>: " & Colour_Table(i, 3) & "</li>"
0355 End If
0356 Next i
0357 strLine = strLine & "</OL>"
0358 Else
0359 OK = Mark_Colours(strLine)
0360 End If
0361 End If
0362 tsTextFile.WriteLine strLine
0363 rsTableControl.MoveNext
0364 Loop
0365 'Copy page to Transfer directory
0366 If Test_Flag = True Then
0367 sw2.StartTimer
0368 End If
0369 OK = CopyToTransfer(strFolder, strFileName)
0370 If Test_Flag = True Then
0371 Debug.Print Now(); strFileName; sw2.EndTimer; "Milliseconds"; " CopyToTransfer"
0372 Debug.Print Now(); strFileName; sw.EndTimer; "Milliseconds"
0373 End If
0374 iCount = iCount + 1
0375 rsTableToRead.MoveNext
0376 Loop
0377 If Run_Type <> "Changed" Then
0378 'Update the Book_Abstract_Ranges Table
0379 Duration = Now() - StartTime
0380 Duration = Duration * 24 * 60
0381 Duration = Round(Duration, 1)
0382 RunDate = Now()
0383 rsTableToRead2.Edit
0384 rsTableToRead2.Fields(4) = RunDate
0385 rsTableToRead2.Fields(5) = Duration
0386 rsTableToRead2.Update
0387 'Read Next Range
0388 rsTableToRead2.MoveNext
0389 If rsTableToRead2.EOF Then
0390 All_Done = True
0391 End If
0392 DoCmd.OpenQuery ("Book_Summary_Temp_Zap")
0393 StartTime = Now()
0394 End If
0395Loop
0396Set rsTableToRead = Nothing
0397Set rsTableToRead2 = Nothing
0398Set rsNoteBookLinksDB = Nothing
0399Set fsoTextFile = Nothing
0400Set tsTextFile = Nothing
0401If Test_Flag = True Then
0402 Set sw = Nothing
0403 Set sw2 = Nothing
0404End If
0405If automatic_processing <> "Yes" And strNoMessages = "No" Then
0406 Duration = Round((Now() - RunStartTime) * 24 * 60, 1)
0407 If Duration < 1 Then
0408 Duration = Round((Now() - RunStartTime) * 24 * 60 * 60)
0409 MsgBox Now() & ": BookSummary Webpage Creation Complete in " & Duration & " seconds. " & iCount & " pages output.", vbOKOnly, "Create BookSummary Web Pages"
0410 Else
0411 MsgBox Now() & ": BookSummary Webpage Creation Complete in " & Duration & " minutes. " & iCount & " pages output.", vbOKOnly, "Create BookSummary Web Pages"
0412 End If
0413End If
0414End Sub

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


Source Code of: CreateQueryWebpages
Procedure Type: Public Sub
Module: Documentation
Lines of Code: 273
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub CreateQueryWebpages()
0002Dim rsTableControl As Recordset
0003Dim strControlQuery As String
0004Dim strLine As String
0005Dim iTableColumns As Integer
0006Dim i As Long
0007Dim strFileSuffix As String
0008Dim strFileBody As String
0009Dim Procedure_Type As String
0010Dim Heading As String
0011Dim rsTableToRead As Recordset
0012Dim rsTableToRead2 As Recordset
0013Dim rsProcedure_Location As Recordset
0014Dim Procedure_Location As Integer
0015Dim Query_Type As Integer
0016Dim Query_Type_Saved As Integer
0017Dim This_Location As Integer
0018Dim This_Object As String
0019Dim This_Object_Count As String
0020Dim This_Line As Integer
0021Dim Last_Location As Integer
0022Dim Last_Object As String
0023Dim Last_Line As Integer
0024Dim strMainText As String
0025Dim strLinks As String
0026Dim strOutputFileShort_Saved As String
0027'Create the Query Detail Files (by Query-Type)
0028'Read the data
0029 strDataQuery = "SELECT Query_Definitions.* FROM Query_Definitions ORDER BY Query_Definitions.Query_Type, Query_Definitions.Query_Name;"
0030Set rsTableToRead = CurrentDb.OpenRecordset(strDataQuery)
0031rsTableToRead.MoveFirst
0032Query_Type = rsTableToRead.Fields(1)
0033Query_Type_Saved = Query_Type
0034Select Case Query_Type
0035 Case 0
0036 Heading = "Select"
0037 Case 16
0038 Heading = "Cross-Tab"
0039 Case 32
0040 Heading = "Delete"
0041 Case 48
0042 Heading = "Update"
0043 Case 64
0044 Heading = "Append"
0045 Case 80
0046 Heading = "Make-Table"
0047 Case 128
0048 Heading = "Union"
0049 Case Else
0050 Heading = "Unknown (" & Query_Type & ")"
0051End Select
0052'Create First File
0053strOutputFileShort = SubSystem & "Documentation_Code_Queries_" & Query_Type
0054strOutputFileShort_Saved = strOutputFileShort
0055Set tsTextFile = fsoTextFile2.CreateTextFile(strOutputFolder & strFileBody & strOutputFileShort & ".htm", True, True)
0056'Create First Page Header
0057 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;"
0058Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0059rsTableControl.MoveFirst
0060Do While Not rsTableControl.EOF
0061 strLine = rsTableControl.Fields(0) & ""
0062 tsTextFile.WriteLine strLine
0063 rsTableControl.MoveNext
0064Loop
0065'Create Jump Table
0066iTableColumns = 4
0067Procedure_Type = "Query"
0068Heading = "Query Documentation: Query-Type = " & Heading
0069Procedure_Location = Query_Type
0070 OK = CreateDocumentationJumpTables(Procedure_Type, Heading, iTableColumns, Procedure_Location)
0071Do Until rsTableToRead.EOF
0072 Query_Type = rsTableToRead.Fields(1)
0073 If Query_Type <> Query_Type_Saved Then
0074 Query_Type_Saved = Query_Type
0075 'Finish last file
0076 'Page Footer
0077 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;"
0078 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0079 rsTableControl.MoveFirst
0080 Do While Not rsTableControl.EOF
0081 strLine = rsTableControl.Fields(0) & ""
0082 OK = Replace_Timestamp(strLine)
0083 tsTextFile.WriteLine strLine
0084 rsTableControl.MoveNext
0085 Loop
0086 'Copy to Transfer
0087 strFileSuffix = strOutputFileShort_Saved
0088 OK = CopyToTransfer(strFolder & strFileBody, strFileSuffix & ".htm")
0089 Set tsTextFile = Nothing
0090 'Create File
0091 strOutputFileShort = SubSystem & "Documentation_Code_Queries_" & Query_Type
0092 strOutputFileShort_Saved = strOutputFileShort
0093 Set tsTextFile = fsoTextFile2.CreateTextFile(strOutputFolder & strFileBody & strOutputFileShort & ".htm", True, True)
0094 'Create Page Header
0095 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;"
0096 Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0097 rsTableControl.MoveFirst
0098 Do While Not rsTableControl.EOF
0099 strLine = rsTableControl.Fields(0) & ""
0100 tsTextFile.WriteLine strLine
0101 rsTableControl.MoveNext
0102 Loop
0103 Select Case Query_Type
0104 Case 0
0105 Heading = "Select"
0106 Case 16
0107 Heading = "Cross-Tab"
0108 Case 32
0109 Heading = "Delete"
0110 Case 48
0111 Heading = "Update"
0112 Case 64
0113 Heading = "Append"
0114 Case 80
0115 Heading = "Make-Table"
0116 Case 128
0117 Heading = "Union"
0118 Case Else
0119 Heading = "Unknown (" & Query_Type & ")"
0120 End Select
0121 'Create Jump Table
0122 iTableColumns = 4
0123 Procedure_Type = "Query"
0124 Heading = "Query Documentation: Query-Type = " & Heading
0125 Procedure_Location = Query_Type
0126 OK = CreateDocumentationJumpTables(Procedure_Type, Heading, iTableColumns, Procedure_Location)
0127 End If
0128 'Create Main Text
0129 For i = 1 To rsTableToRead.Fields.Count
0130 Heading = rsTableToRead.Fields(i - 1)
0131 If i = 1 Then
0132 strLine = "<A Name =""" & Heading & """></A>" & "<B>" & rsTableToRead.Fields(i - 1).Name & ": " & Heading & "</B><BR>"
0133 Else
0134 If i = 2 Then
0135 Select Case Heading
0136 Case 0
0137 Heading = "Select"
0138 Case 16
0139 Heading = "Cross-Tab"
0140 Case 32
0141 Heading = "Delete"
0142 Case 48
0143 Heading = "Update"
0144 Case 64
0145 Heading = "Append"
0146 Case 80
0147 Heading = "Make-Table"
0148 Case 128
0149 Heading = "Union"
0150 Case Else
0151 Heading = "Unknown (" & Heading & ")"
0152 End Select
0153 Else
0154 If i = 5 Then
0155 Heading = "<FONT SIZE = ""3""><xmp>" & Heading & ""
0156 End If
0157 End If
0158 strLine = strLine & "<B>" & rsTableToRead.Fields(i - 1).Name & ":</B> " & Heading & "<BR>"
0159 End If
0160 Next i
0161 strMainText = strLine
0162 strLine = strLine & "<b>Link To Column Definitions: </b><A HREF=""" & SubSystem & "Documentation_Queries_" & rsTableToRead.Fields(0) & ".htm"">" & rsTableToRead.Fields(0) & "</A><br><br>"
0163 tsTextFile.WriteLine strLine
0164 strLine = ""
0165 'Create Links Out
0166 strDataQuery = "SELECT Query_Links_Table.*, Query_Definitions.Query_Type FROM Query_Links_Table LEFT JOIN Query_Definitions ON Query_Links_Table.Object_2 = Query_Definitions.Query_Name WHERE (((Query_Links_Table.Object_1) = """ & rsTableToRead.Fields(0).Value & """)) ORDER BY Query_Links_Table.Object_2;"
0167 Set rsTableToRead2 = CurrentDb.OpenRecordset(strDataQuery)
0168 If Not rsTableToRead2.EOF Then
0169 rsTableToRead2.MoveFirst
0170 strLine = strLine & "<U><B>Tables / Queries Used By This Query</U></B><UL>"
0171 Do While Not rsTableToRead2.EOF
0172 If rsTableToRead2.Fields(3) = "Q" Then
0173 strLine = strLine & "<LI><A HREF=""" & SubSystem & "Documentation_Code_Queries_" & rsTableToRead2.Fields(5) & ".htm#" & rsTableToRead2.Fields(2) & """>" & rsTableToRead2.Fields(2) & "</A>" & " (Query)</LI>"
0174 Else
0175 strLine = strLine & "<LI><A HREF=""" & SubSystem & "Documentation_Code_Tables.htm#" & rsTableToRead2.Fields(2) & """>" & rsTableToRead2.Fields(2) & "</A>" & " (Table)</LI>"
0176 End If
0177 rsTableToRead2.MoveNext
0178 Loop
0179 strLine = strLine & "</UL>"
0180 End If
0181 'Create Query Links In
0182 strDataQuery = "SELECT Query_Links_Table.*, Query_Definitions.Query_Type FROM Query_Links_Table LEFT JOIN Query_Definitions ON Query_Links_Table.Object_1 = Query_Definitions.Query_Name WHERE (((Query_Links_Table.Object_2) = """ & rsTableToRead.Fields(0).Value & """) AND Query_Links_Table.Object_1_Type = ""Q"") ORDER BY Query_Links_Table.Object_1_Type, Query_Links_Table.Object_1, Query_Links_Table.Code_Line;"
0183 Set rsTableToRead2 = CurrentDb.OpenRecordset(strDataQuery)
0184 If Not rsTableToRead2.EOF Then
0185 rsTableToRead2.MoveFirst
0186 strLine = strLine & "<U><B>Queries Using this Query</U></B><UL>"
0187 Do While Not rsTableToRead2.EOF
0188 strLine = strLine & "<LI><A HREF=""" & SubSystem & "Documentation_Code_Queries_" & rsTableToRead2.Fields(5) & ".htm#" & rsTableToRead2.Fields(0) & """>" & rsTableToRead2.Fields(0) & "</A>" & "</LI>"
0189 rsTableToRead2.MoveNext
0190 Loop
0191 strLine = strLine & "</UL>"
0192 End If
0193 'Create Code Links In
0194 strDataQuery = "SELECT Query_Links_Table.*, Query_Definitions.Query_Type FROM Query_Links_Table LEFT JOIN Query_Definitions ON Query_Links_Table.Object_1 = Query_Definitions.Query_Name WHERE (((Query_Links_Table.Object_2) = """ & rsTableToRead.Fields(0).Value & """) AND Query_Links_Table.Object_1_Type = ""C"") ORDER BY Query_Links_Table.Object_1_Type, Query_Links_Table.Object_1, Query_Links_Table.Code_Line;"
0195 Set rsTableToRead2 = CurrentDb.OpenRecordset(strDataQuery)
0196 If Not rsTableToRead2.EOF Then
0197 rsTableToRead2.MoveFirst
0198 strLine = strLine & "<U><B>Code Using this Query</U></B><UL>"
0199 Last_Object = "zzzz"
0200 This_Object_Count = 0
0201 Do While Not rsTableToRead2.EOF
0202 This_Object = rsTableToRead2.Fields(0)
0203 'Find the Code_Location ...
0204 Set rsProcedure_Location = CurrentDb.OpenRecordset("Select Code_Location.Code_Location FROM Code_Location WHERE Code_Location.Procedure_Name = """ & This_Object & """;")
0205 rsProcedure_Location.MoveFirst
0206 This_Location = rsProcedure_Location.Fields(0)
0207 This_Line = rsTableToRead2.Fields(4)
0208 If Last_Object = This_Object Then
0209 If This_Object_Count = 1 Then
0210 strLine = strLine & "<LI>" & Last_Object & " (From Lines <A HREF=""" & SubSystem & "Documentation_Code_" & Last_Location & ".htm#" & Last_Object & "_" & Last_Line & """>" & Last_Line & "</A>, "
0211 Else
0212 strLine = strLine & "<A HREF=""" & SubSystem & "Documentation_Code_" & Last_Location & ".htm#" & Last_Object & "_" & Last_Line & """>" & Last_Line & "</A>, "
0213 End If
0214 This_Object_Count = This_Object_Count + 1
0215 Else
0216 If Last_Object <> "zzzz" Then
0217 If This_Object_Count = 1 Then
0218 strLine = strLine & "<LI>" & Last_Object & " (From Line <A HREF=""" & SubSystem & "Documentation_Code_" & Last_Location & ".htm#" & Last_Object & "_" & Last_Line & """>" & Last_Line & "</A>)</LI>"
0219 Else
0220 strLine = strLine & "<A HREF=""" & SubSystem & "Documentation_Code_" & Last_Location & ".htm#" & Last_Object & "_" & Last_Line & """>" & Last_Line & "</A>)</LI>"
0221 End If
0222 End If
0223 This_Object_Count = 1
0224 End If
0225 rsTableToRead2.MoveNext
0226 Last_Location = This_Location
0227 Last_Object = This_Object
0228 Last_Line = This_Line
0229 Loop
0230 'Last line
0231 If Last_Object <> "zzzz" Then
0232 If This_Object_Count = 1 Then
0233 strLine = strLine & "<LI>" & Last_Object & " (From Line <A HREF=""" & SubSystem & "Documentation_Code_" & Last_Location & ".htm#" & Last_Object & "_" & Last_Line & """>" & Last_Line & "</A>)</LI>"
0234 Else
0235 strLine = strLine & "<A HREF=""" & SubSystem & "Documentation_Code_" & Last_Location & ".htm#" & Last_Object & "_" & Last_Line & """>" & Last_Line & "</A>)</LI>"
0236 End If
0237 End If
0238 strLine = strLine & "</UL>"
0239 End If
0240 strLinks = strLine
0241 tsTextFile.WriteLine strLine
0242 strLine = ""
0243 'Regenerate the field-list page (if changed since last run)
0244 If rsTableToRead.Fields(3) > Documentation_Last_Run Or Document_Queries_Full = True Then
0245 OK = Document_Object_Columns(rsTableToRead.Fields(0), "Query", SubSystem & "Documentation_Code_Queries", strMainText, strLinks)
0246 End If
0247 strLine = ""
0248 'Create link to top of page
0249 strLine = strLine & "<A HREF=""#Top"">Go To Top of This Page</A><br>"
0250 tsTextFile.WriteLine strLine
0251 'Create link to main code jump-table
0252 strLine = "<A HREF=""" & SubSystem & "DocumentationControl.htm"">Link to VBA Code Control Page</A><br>"
0253 tsTextFile.WriteLine strLine
0254 'Rule off ready for next procedure
0255 strLine = "<BR><HR>"
0256 tsTextFile.WriteLine strLine
0257 rsTableToRead.MoveNext
0258Loop
0259'Finish Last File
0260'Page Footer
0261 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;"
0262Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0263rsTableControl.MoveFirst
0264Do While Not rsTableControl.EOF
0265 strLine = rsTableControl.Fields(0)
0266 OK = Replace_Timestamp(strLine)
0267 tsTextFile.WriteLine strLine
0268 rsTableControl.MoveNext
0269Loop
0270'Copy to Transfer
0271strFileSuffix = strOutputFileShort_Saved
0272 OK = CopyToTransfer(strFolder, strFileSuffix & ".htm")
0273End Sub

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


© Theo Todman, June 2007 - April 2026. 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