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

cmdBookCitings_ClickcmdDashboard_ClickAuthor_Reference_StringReference_Tables
Check_TypesForms_DocumenterNotes_List_Export.

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

Go to top of page



Source Code of: Author_Reference_String
Procedure Type: Public Function
Module: New Code
Lines of Code: 62
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Author_Reference_String(strAuthors, iDepth)
0002Dim i As Long
0003Dim j As Long
0004Dim k As Long
0005Dim strAuthorsLocal As String
0006Dim strPrefix As String
0007Dim strAuthorFound As String
0008Dim strAuthorsLocalList As String
0009Dim strAuthorsLocalDelimeter As String
0010i = 0
0011k = 1
0012strAuthorsLocal = strAuthors
0013strPrefix = ""
0014Do Until i = iDepth
0015 strPrefix = strPrefix & "../"
0016 i = i + 1
0017Loop
0018i = 1
0019strAuthorsLocalDelimeter = ""
0020Do While i + j > 0
0021 i = InStr(k, strAuthorsLocal, ",")
0022 j = InStr(k, strAuthorsLocal, "&")
0023 If j > i Then
0024 If i > 0 Then
0025 strAuthorFound = Trim(Mid(strAuthorsLocal, k, i - k))
0026 strAuthorsLocalDelimeter = ", "
0027 k = i + 1
0028 Else
0029 strAuthorFound = Trim(Mid(strAuthorsLocal, k, j - k))
0030 strAuthorsLocalDelimeter = " & "
0031 k = j + 1
0032 End If
0033 Else
0034 If j > 0 Then
0035 strAuthorFound = Trim(Mid(strAuthorsLocal, k, j - k))
0036 strAuthorsLocalDelimeter = " & "
0037 k = j + 1
0038 Else
0039 If i > 0 Then
0040 strAuthorFound = Trim(Mid(strAuthorsLocal, k, i - k))
0041 strAuthorsLocalDelimeter = ", "
0042 k = i + 1
0043 Else
0044 strAuthorFound = Trim(Mid(strAuthorsLocal, k, Len(strAuthorsLocal)))
0045 strAuthorsLocalDelimeter = ""
0046 End If
0047 End If
0048 End If
0049 If InStr(strAuthorFound, "(") > 0 Then
0050 strAuthorFound = "<A HREF = """ & strPrefix & "Authors/" & UCase(Left(strAuthorFound, 1)) & "/Author_" & strAuthorFound & ".htm"">" & strAuthorFound & "</a>"
0051 Else
0052 Select Case strAuthorFound
0053 Case "Dud", "Ed.", "Ed", "Eds.", "Eds", "Etc", "Etc.", "Unknown Author"
0054 Case Else
0055 strAuthorFound = "<A HREF = """ & strPrefix & "Authors/" & UCase(Left(strAuthorFound, 1)) & "/Author_" & strAuthorFound & ".htm"">" & strAuthorFound & "</a>"
0056 End Select
0057 End If
0058 strAuthorsLocalList = strAuthorsLocalList & strAuthorFound & strAuthorsLocalDelimeter
0059Loop
0060'Return final string
0061strAuthors = strAuthorsLocalList
0062End Function

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


Source Code of: Check_Types
Procedure Type: Public Sub
Module: New Code
Lines of Code: 65
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Check_Types()
0002Dim rsCheck As Recordset
0003Dim Directory As String
0004Dim NameBody As String
0005Dim FileName As String
0006Dim File_Type As String
0007Directory = TheoWebsiteRoot & "\"
0008'Subjects
0009 Set rsCheck = CurrentDb.OpenRecordset("Select * FROM Subjects;")
0010rsCheck.MoveFirst
0011Do Until rsCheck.EOF
0012 NameBody = "BookCatalogCategorised_Top"
0013 FileName = Directory & NameBody & "_" & rsCheck.Fields(0) & ".htm"
0014 If Dir(FileName) <> "" Then
0015 File_Type = "Top"
0016 Else
0017 NameBody = "BookCatalogCategorised"
0018 FileName = Directory & NameBody & "_" & rsCheck.Fields(0) & ".htm"
0019 If Dir(FileName) <> "" Then
0020 File_Type = "ID"
0021 Else
0022 File_Type = "None"
0023 End If
0024 End If
0025 rsCheck.Edit
0026 rsCheck.Fields(3) = File_Type
0027 rsCheck.Update
0028 rsCheck.MoveNext
0029Loop
0030Set rsCheck = Nothing
0031'Sub_Topics
0032 Set rsCheck = CurrentDb.OpenRecordset("Select * FROM [Sub-Topics];")
0033rsCheck.MoveFirst
0034Do Until rsCheck.EOF
0035 NameBody = "PaperCatalogPhilosophyFullCategorisedSubTopic_"
0036 FileName = Directory & NameBody & rsCheck.Fields(0) & ".htm"
0037 If Dir(FileName) <> "" Then
0038 File_Type = "ID"
0039 Else
0040 File_Type = "None"
0041 End If
0042 rsCheck.Edit
0043 rsCheck.Fields(4) = File_Type
0044 rsCheck.Update
0045 rsCheck.MoveNext
0046Loop
0047Set rsCheck = Nothing
0048'Topics
0049 Set rsCheck = CurrentDb.OpenRecordset("Select * FROM [Topics];")
0050rsCheck.MoveFirst
0051Do Until rsCheck.EOF
0052 NameBody = "PaperCatalogPhilosophyFullCategorised_Top_"
0053 FileName = Directory & NameBody & rsCheck.Fields(0) & ".htm"
0054 If Dir(FileName) <> "" Then
0055 File_Type = "ID"
0056 Else
0057 File_Type = "None"
0058 End If
0059 rsCheck.Edit
0060 rsCheck.Fields(3) = File_Type
0061 rsCheck.Update
0062 rsCheck.MoveNext
0063Loop
0064Set rsCheck = Nothing
0065End Sub

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


Source Code of: cmdBookCitings_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 30
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Private Sub cmdBookCitings_Click()
0002Dim strMessage As String
0003Dim StartTime As Double
0004Dim rsTableToRead As Recordset
0005Dim rsTableToRead2 As Recordset
0006Dim Duration As Double
0007Dim strRunTime As String
0008Dim RunDate As Date
0009 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT * FROM BookPaperControl WHERE ID = ""WebpageGenBookCitations"";")
0010RunDate = rsTableToRead.Fields(1)
0011strRunTime = Round(rsTableToRead.Fields(2), 1)
0012strMessage = "Do you want to regenerate the ""Books Citations Links"" page (after first regenerating the individual Book Citations pages)?"""
0013strMessage = strMessage & Chr$(10) & "The last run on " & RunDate & " took " & strRunTime & " minutes."
0014RootCreated = ""
0015If MsgBox(strMessage, vbYesNo) = vbYes Then
0016 StartTime = Now()
0017 WebpageGenBookCitings ("Yes")
0018 WebpageGenBookCitingsPage
0019 Duration = Round((Now() - StartTime) * 24 * 60, 1)
0020 rsTableToRead.Edit
0021 rsTableToRead.Fields(1) = Now()
0022 rsTableToRead.Fields(2) = Duration
0023 rsTableToRead.Update
0024Else
0025 Exit Sub
0026End If
0027MsgBox "Book Citings Pages Creation Complete in " & Duration & " minutes.", vbOKOnly, "Create Book Citings Pages"
0028Set rsTableToRead = Nothing
0029Set rsTableToRead2 = Nothing
0030End Sub

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


Source Code of: cmdDashboard_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 10

Line-No. / Ref.Code Line
0001Private Sub cmdDashboard_Click()
0002 DoCmd.OpenTable ("Thesis_Progress_Dashboard")
0003MsgBox ("Update this table, then continue, to run the monthly report")
0004Stop
0005'Determine the Title year & month ...
0006StrTitle_Year = Year(Now())
0007StrTitle_Month = MonthName(Month(Now()))
0008 Monthly_Report_Note1024_Output
0009MsgBox ("Thesis Progress Dashboard output OK")
0010End Sub

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


Source Code of: Forms_Documenter
Procedure Type: Public Sub
Module: Documentation
Lines of Code: 164
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Forms_Documenter()
0002'Currently only covers the MainForm
0003 Dim ctl As Control
0004Dim rst As Recordset
0005Dim strQuery As String
0006Dim strLine As String
0007Dim strLine_Temp As String
0008Dim strTable As String
0009Dim strColor As String
0010Dim strTableElement As String
0011Dim strCodeNote
0012Dim rsTableControl As Recordset
0013Dim rsTableControl2 As Recordset
0014Dim rsTableControl3 As Recordset
0015Dim strCols As String
0016Dim iCols As Integer
0017Dim iCols_Saved As Integer
0018Dim ifields As Integer
0019Dim i As Integer
0020Dim j As Long
0021Dim k As Long
0022Dim colWidth As Integer
0023Dim Note_For_Update As Integer
0024'Regenerate the Form Controls Table for MainForm
0025 strQuery = "DELETE * FROM Form_Controls_Table WHERE Form_Name = ""MainForm"";"
0026DoCmd.RunSQL (strQuery)
0027 Set rst = CurrentDb.OpenRecordset("SELECT * FROM Form_Controls_Table WHERE Form_Name = ""MainForm"";")
0028For Each ctl In Forms![MainForm].Controls
0029 rst.AddNew
0030 rst.Fields(0) = "MainForm"
0031 rst.Fields(1) = ctl.Name
0032 rst.Fields(2) = ctl.ControlType 'acCommandButton = 104
0033 If ctl.ControlType <> 111 Then 'Drop-down boxes don't have Captions
0034 rst.Fields(3) = ctl.Caption
0035 End If
0036 rst.Fields(4) = ctl.Width
0037 rst.Fields(5) = ctl.Height
0038 rst.Fields(6) = ctl.Top
0039 rst.Fields(7) = ctl.Left
0040 rst.Fields(8) = ctl.ForeColor
0041 rst.Fields(9) = ctl.OnClick
0042 rst.Update
0043Next ctl
0044If SubSystem = "Bridge" Then 'Temporary expedient ... eventually remove the code below that creates the Note
0045 strLine = ""
0046Else
0047 strLine = "<u>Introduction</u>|99||1|This page is generated by +CForms_DocumenterC+, so don't try updating this Note directly!"
0048 strLine = strLine & "|1|For a high-level and not terribly up-to-date Functional Overview of my website and its generator, see [this Note]++1286++."
0049 strLine = strLine & "|1|Herewith the <a href = ""../Notes_Jump_13.htm"">Jump Table</a> of the Documentation Notes I've so far written."
0050 strLine = strLine & "|1|Herewith the <a href = ""../../Documentation/DocumentationControl.htm"">VBA Code Control Page</a> for easy access to the code and tables + queries used to generate the site. "
0051 strLine = strLine & "|1|Tables showing (approximately++FN|..||.|The date/times are those of the documenter-run that archived the particular version of the code. |.|So, they are ""latest"" dates, the ""earliest"" being that of the previous archive. |.|I've not written routines to display the archived code, as there's been no need for it. |..| ++) when the underlying procedures were updated are given via the links below:-|..||.|<a href = ""../../Documentation/Code_Archive_Recent.htm"">Recent</a> |.|<a href = ""../../Documentation/Code_Archive.htm"">Full List</a> |..|"
0052 strLine = strLine & "|1|The documents detailing recent updates and outstanding developments to my Website are given via the links below:-|..||.|[Quarterly Status Report]++520++ |.|[Progress to Date]++822++ |.|[Outstanding Developments]++981++ |..|"
0053 strLine = strLine & "|1|A bitmap of the front screen of the MS Access application that generates my website is as below:-|99|<hr><p>&nbsp;</p><CENTER><IMG ALIGN=CENTER ALT=""Front Screen"" WIDTH=1125 SRC=""../../Main_Screen_2020-02-10.png""></CENTER><p>&nbsp;</p><hr><p>&nbsp;</p>"
0054 strLine = strLine & "<p>A schematic representation of the front screen is as below. |..||.|I know it's a bit crowded, but it's for private use. |.|Click on ""Code"" for links through to the VBA code. |.|For functional documentation, click on ""Note"". The functions are bunched into classes, so many links will take you to the same place initially. |.|The usual colour-conventions are not followed. This is all my own work! |.|This Note is awaiting further attention++999++.|..|</p><p>&nbsp;</p><hr><p>&nbsp;</p>"
0055End If
0056If SubSystem = "Bridge" Then
0057 strQuery = "TRANSFORM First(Form_Controls_Table.Control_Name) AS FirstOfControl_Name SELECT 1+Round(([Control_Top]-113)/567) AS X FROM Form_Controls_Table WHERE (((Form_Controls_Table.Form_Name) = ""MainForm"")) GROUP BY 1+Round(([Control_Top]-113)/567) ORDER BY 1+Round(([Control_Top]-113)/567), 1+Round(([Control_Left]-566)/2000) PIVOT 1+Round(([Control_Left]-566)/2000);"
0058Else
0059 strQuery = "TRANSFORM First(Form_Controls_Table.Control_Name) AS FirstOfControl_Name SELECT 1+Round(([Control_Top]-113)/567) AS X FROM Form_Controls_Table WHERE (((Form_Controls_Table.Form_Name) = ""MainForm"")) GROUP BY 1+Round(([Control_Top]-113)/567) ORDER BY 1+Round(([Control_Top]-113)/567), 1+Round(([Control_Left]-566)/4534) PIVOT 1+Round(([Control_Left]-566)/4534);"
0060End If
0061Set rsTableControl2 = CurrentDb.OpenRecordset(strQuery)
0062strTable = "<CENTER><TABLE WIDTH=1125 class = ""Bridge"">"
0063rsTableControl2.MoveFirst
0064ifields = rsTableControl2.Fields.Count - 1
0065colWidth = 100 / ifields
0066Do Until rsTableControl2.EOF
0067 strCols = ""
0068 iCols_Saved = 1
0069 strTable = strTable & "<TR>"
0070 For i = 1 To ifields
0071 strTableElement = "&nbsp;"
0072 strCols = ""
0073 iCols = 1
0074 If rsTableControl2.Fields(i) & "" <> "" Then
0075 strQuery = "SELECT Form_Controls_Table.Control_Name, Form_Controls_Table.Control_Caption, Form_Controls_Table.Control_Width, Form_Controls_Table.Control_ForeColour, Form_Controls_Table.Control_Type, Form_Controls_Table.Control_OnClickEvent, Form_Documentation_Links.Note FROM Form_Controls_Table LEFT JOIN Form_Documentation_Links ON (Form_Controls_Table.Control_Name = Form_Documentation_Links.Control_Name) AND (Form_Controls_Table.Form_Name = Form_Documentation_Links.Form_Name) WHERE (((Form_Controls_Table.Form_Name)=""MainForm"") AND ((Form_Controls_Table.Control_Name)=""" & rsTableControl2.Fields(i) & """));"
0076 Set rsTableControl3 = CurrentDb.OpenRecordset(strQuery)
0077 If Not rsTableControl3.EOF Then
0078 strTableElement = rsTableControl3.Fields(1) & ""
0079 Select Case rsTableControl3.Fields(3)
0080 Case 255
0081 strColor = "red"
0082 Case 16711680
0083 strColor = "blue"
0084 Case 8210719
0085 strColor = "#8210719"
0086 Case Else
0087 strColor = "black"
0088 End Select
0089 strTableElement = "<font color=""" & strColor & """>" & strTableElement & "</font>"
0090 strCodeNote = ""
0091 If rsTableControl3.Fields(5) = "[Event Procedure]" Then
0092 strCodeNote = "+C" & rsTableControl2.Fields(i) & "_ClickC+"
0093 End If
0094 If rsTableControl3.Fields(6) & "" > "" Then
0095 If strCodeNote <> "" Then
0096 strCodeNote = strCodeNote & " + "
0097 End If
0098 strCodeNote = strCodeNote & "Note++" & rsTableControl3.Fields(6) & "++"
0099 End If
0100 If strCodeNote <> "" Then
0101 strTableElement = strTableElement & "<br>" & strCodeNote
0102 End If
0103 iCols = Round(rsTableControl3.Fields(2) / 4534)
0104 If iCols > 1 Then
0105 strCols = " colspan=" & iCols
0106 Else
0107 strCols = ""
0108 End If
0109 End If
0110 End If
0111 If iCols_Saved < 2 Then
0112 strTable = strTable & "<TD" & strCols & " WIDTH=""" & colWidth & "%"">" & strTableElement & "</TD>"
0113 iCols_Saved = iCols
0114 Else
0115 iCols_Saved = iCols_Saved - 1
0116 End If
0117 Next i
0118 strTable = strTable & "</TR>"
0119 rsTableControl2.MoveNext
0120Loop
0121strTable = strTable & "</TABLE></CENTER>"
0122strLine = strLine & strTable
0123If SubSystem <> "Bridge" Then
0124 OK = Reference_Code(strLine, 2, "No") 'Is this needed ... it mucks up the Bridge version, hence its exclusion
0125End If
0126'Read & update "Website Generator Documentation" Note
0127If SubSystem = "Bridge" Then
0128 Note_For_Update = 1001
0129Else
0130 Note_For_Update = 841
0131End If
0132 strQuery = "SELECT Notes.* FROM Notes WHERE Notes.ID = " & Note_For_Update & ";"
0133Set rsTableControl = CurrentDb.OpenRecordset(strQuery)
0134rsTableControl.MoveFirst
0135rsTableControl.Edit
0136If SubSystem = "Bridge" Then 'Temporary expedient ... eventually remove the code above that creates the Note
0137 strLine_Temp = rsTableControl.Fields(3)
0138 j = InStr(strLine_Temp, "<!-- FORM_START -->")
0139 j = j + Len("<!-- FORM_START -->")
0140 k = InStr(strLine_Temp, "<!-- FORM_END -->")
0141 If i > 0 And j > 0 Then
0142 strLine = Left(strLine_Temp, j - 1) & strLine & Mid(strLine_Temp, k)
0143 End If
0144End If
0145rsTableControl.Fields(3) = strLine
0146rsTableControl.Fields(10) = "Temp"
0147rsTableControl.Update
0148'Output the note
0149 DoCmd.RunSQL ("DELETE Notes_To_Regen.* FROM Notes_To_Regen;")
0150 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Notes_To_Regen.* FROM Notes_To_Regen;")
0151rsTableControl.AddNew
0152rsTableControl.Fields(0) = Note_For_Update
0153rsTableControl.Fields(1) = Now()
0154rsTableControl.Update
0155Archive_Notes_Now = "No"
0156Regenerate_the_Links = "No"
0157Regen_Notes_Only = "Yes"
0158automatic_processing = "Yes"
0159 CreateNotesWebPages
0160'tidy Up
0161Set rsTableControl = Nothing
0162Set rsTableControl2 = Nothing
0163Set rsTableControl3 = Nothing
0164End Sub

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


Source Code of: Notes_List_Export
Procedure Type: Public Sub
Module: Testing
Lines of Code: 210
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Notes_List_Export()
0002'Create web-page of all Notes web-pages
0003Dim strOutputFolder As String
0004Dim strOutputFile As String
0005Dim strLine As String
0006Dim rsTableControl2 As Recordset
0007Dim i As Integer
0008Dim j As Integer
0009Dim FileName As String
0010Dim FileName_Root As String
0011Dim ifields As Integer
0012Dim Field_Width As Single
0013Dim Field_Width_Changed As Single
0014Dim x As String
0015Dim Y As String
0016Dim Y_Saved As String
0017Dim xDate As Date
0018Dim ID As Integer
0019Dim ID_Saved As Integer
0020Dim strJump_Table As String
0021Dim strFile_Sub As String
0022Dim strColor As String
0023DoEvents
0024 Set rsTableControl2 = CurrentDb.OpenRecordset("Notes_Archive_Files_Checker")
0025rsTableControl2.MoveLast
0026DoEvents
0027FileName_Root = "Notes_List_Control"
0028'Create the jump table ...
0029ifields = rsTableControl2.Fields(0)
0030ifields = ifields / 100
0031If ifields * 100 < rsTableControl2.Fields(0) Then
0032 ifields = ifields + 1
0033End If
0034Field_Width = 100 / ifields
0035rsTableControl2.MoveFirst
0036strJump_Table = "<TABLE class = ""Bridge"" WIDTH=1000>"
0037strJump_Table = strJump_Table & "<tr>"
0038For i = 0 To ifields - 1
0039 If i = 0 Then
0040 strFile_Sub = ""
0041 Else
0042 strFile_Sub = "_" & Right(100 + i, 2)
0043 End If
0044 strJump_Table = strJump_Table & "<th WIDTH=""" & Field_Width & "%""><a href=""" & FileName_Root & strFile_Sub & ".htm"">" & i * 100 & "+</a></th>"
0045Next i
0046strJump_Table = strJump_Table & "</tr></TABLE><p>&nbsp;</p>"
0047ifields = rsTableControl2.Fields.Count
0048Field_Width = Round(100 / (ifields + 5))
0049strOutputFolder = TheoWebsiteRoot & "\"
0050Set fsoTextFile2 = New FileSystemObject
0051FileName_Root = "Notes_List_Control"
0052Y_Saved = ""
0053ID_Saved = 0
0054Do While Not rsTableControl2.EOF
0055 ID = rsTableControl2.Fields(0)
0056 Y = Mid(rsTableControl2.Fields(0) + 10000, 2, 2)
0057 i = Val(Y)
0058 If Y <> Y_Saved Then
0059 If Y_Saved <> "" Then
0060 'Terminate & output previous page ...
0061 'Page Footer
0062 strLine = "</TABLE><p></p>"
0063 tsTextFile.WriteLine strLine
0064 strLine = "<h3><a href=""" & FileName_Root & IIf(Y = "00", "", "_" & Y) & ".htm" & """>Next Page</a></h3>"
0065 tsTextFile.WriteLine strLine
0066 strLine = "<TABLE Class = ""Bridge"" WIDTH=1000>"
0067 tsTextFile.WriteLine strLine
0068 strLine = "<TR>"
0069 tsTextFile.WriteLine strLine
0070 strLine = "<TH WIDTH=""30%"">&copy; Theo Todman; Apr. 2007 - " & MonthName(Month(Now())) & " " & Year(Now()) & "</TH>"
0071 tsTextFile.WriteLine strLine
0072 strLine = "<TH WIDTH=""40%"">Please address any comments on this page to <A HREF=""mailto:theo@theotodman.com"">theo@theotodman.com</A>.</TH>"
0073 tsTextFile.WriteLine strLine
0074 strLine = "<TH WIDTH=""30%""><A HREF=""Notes/Notes_10/Notes_1010.htm"" TARGET = ""_top"">Website Maintenance Dashboard</A></TH>"
0075 tsTextFile.WriteLine strLine
0076 strLine = "</TR>"
0077 tsTextFile.WriteLine strLine
0078 strLine = "<TR>"
0079 tsTextFile.WriteLine strLine
0080 strLine = "<TH WIDTH=""30%""><A HREF=""index.htm"" TARGET = ""_top"">Return to Theo Todman's Home Page</A></TH>"
0081 tsTextFile.WriteLine strLine
0082 strLine = "<TH WIDTH=""40%""><A HREF=""Notes/Notes_11/Notes_1140.htm"" TARGET = ""_top"">Return to Theo Todman's Philosophy Page</A></TH>"
0083 tsTextFile.WriteLine strLine
0084 strLine = "<TH WIDTH=""30%"">Timestamp : <time datetime=""" & Year(Now()) & "-" & Right(Month(Now()) + 100, 2) & "-" & Right(Day(Now()) + 100, 2) & """ pubdate>" & Now() & "</time></TH>"
0085 tsTextFile.WriteLine strLine
0086 strLine = "</TR></TABLE></CENTER>"
0087 tsTextFile.WriteLine strLine
0088 OK = CopyToTransfer(strOutputFolder, FileName)
0089 End If
0090 'Set up a new file and header ...
0091 FileName = FileName_Root & IIf(Y = "00", "", "_" & Y) & ".htm"
0092 strOutputFile = strOutputFolder & FileName
0093 Set tsTextFile = fsoTextFile2.CreateTextFile(strOutputFile, True, True)
0094 'Headings
0095 strLine = "<!DOCTYPE html><HTML lang=""en"">"
0096 strLine = strLine & "<HEAD><meta charset=""utf-8""><TITLE>Theo Todman's Consolidated Notes List</TITLE><link href=""TheosStyle.css"" rel=""stylesheet"" type=""text/css""><link rel=""shortcut icon"" href=""TT_ICO.png"" /></HEAD><BODY><H1 align=""center""><B>Theo Todman's Consolidated Notes List</B></H1><CENTER>"
0097 tsTextFile.WriteLine strLine
0098 strLine = "<h3>Theo Todman's Consolidated Notes List</h3>"
0099 strLine = strLine & "<p>This table lists all the Notes on my website. It includes, for each ID, the current ""live"" Note and all archived Notes that are in my database. Archived Notes that were not in my database but which are relics generated prior to my institution of an archiving procedure have now been incorporated in the archive by some ingenious reverse-engineering. Unfortunately, it turned out that a lot of these were duplicates without any value. The purpose of this table is to determine these superfluous Archived Notes so that I can safely delete them. Note that each ""live"" Note has an Archived Note identical to itself. </p>"
0100 tsTextFile.WriteLine strLine
0101 If Y_Saved = "" Then
0102 Y_Saved = "00"
0103 Else
0104 If Y_Saved = "00" Then
0105 strLine = "<h3><a href=""" & FileName_Root & ".htm" & """>Previous Page</a></h3>"
0106 Else
0107 strLine = "<h3><a href=""" & FileName_Root & "_" & Y_Saved & ".htm" & """>Previous Page</a></h3>"
0108 End If
0109 tsTextFile.WriteLine strLine
0110 End If
0111 If Not rsTableControl2.EOF Then
0112 tsTextFile.WriteLine strJump_Table
0113 strLine = "<TABLE class = ""Bridge"" WIDTH=1200>"
0114 tsTextFile.WriteLine strLine
0115 End If
0116 strLine = "<TR>"
0117 tsTextFile.WriteLine strLine
0118 j = 0
0119 Do While j < ifields
0120 If j = 5 Then
0121 Else
0122 Select Case j
0123 Case 3, 6, ifields - 2
0124 Field_Width_Changed = Field_Width * 2
0125 Case 1
0126 Field_Width_Changed = Field_Width * 4
0127 Case Else
0128 Field_Width_Changed = Field_Width
0129 End Select
0130 strLine = "<TH WIDTH=""" & Field_Width_Changed & "%"" > <B>" & rsTableControl2.Fields(j).Name & "</B></TH>"
0131 tsTextFile.WriteLine strLine
0132 End If
0133 j = j + 1
0134 Loop
0135 strLine = "</TR>"
0136 tsTextFile.WriteLine strLine
0137 Y_Saved = Y
0138 End If
0139 strLine = "<TR>"
0140 tsTextFile.WriteLine strLine
0141 j = 0
0142 If ID <> ID_Saved Then
0143 ID_Saved = ID
0144 strColor = " bgcolor=""yellow"""
0145 Else
0146 strColor = ""
0147 End If
0148 Do While j < ifields
0149 If j = 5 Then
0150 Else
0151 x = rsTableControl2.Fields(j) & ""
0152 If j = ifields - 1 Then
0153 If rsTableControl2.Fields(6) = "Supervisions" Then
0154 x = "<A HREF=""Secure_Jen/Notes_" & i & "/" & x & """>" & "Link</A>"
0155 Else
0156 x = "<A HREF=""Notes/Notes_" & i & "/" & x & """>" & "Link</A>"
0157 End If
0158 Else
0159 If j = 3 Or j = (ifields - 1) Then
0160 If x <> "" Then
0161 If x <> "Live Note" Then
0162 xDate = x / 1000
0163 x = xDate
0164 End If
0165 End If
0166 Else
0167 If j = 0 Then
0168 If strColor <> "" Then
0169 x = "<b>--- " & x & " ---</b>"
0170 End If
0171 End If
0172 End If
0173 End If
0174 strLine = "<TD" & strColor & ">" & x & "</TD>"
0175 tsTextFile.WriteLine strLine
0176 End If
0177 j = j + 1
0178 Loop
0179 strLine = "</TR>"
0180 tsTextFile.WriteLine strLine
0181 rsTableControl2.MoveNext
0182Loop
0183'Page Footer
0184strLine = "</TABLE><p></p>"
0185tsTextFile.WriteLine strLine
0186strLine = "<TABLE Class = ""Bridge"" WIDTH=1000>"
0187tsTextFile.WriteLine strLine
0188strLine = "<TR>"
0189tsTextFile.WriteLine strLine
0190strLine = "<TH WIDTH=""30%"">&copy; Theo Todman; Apr. 2007 - " & MonthName(Month(Now())) & " " & Year(Now()) & "</TH>"
0191tsTextFile.WriteLine strLine
0192strLine = "<TH WIDTH=""40%"">Please address any comments on this page to <A HREF=""mailto:theo@theotodman.com"">theo@theotodman.com</A>.</TH>"
0193tsTextFile.WriteLine strLine
0194strLine = "<TH WIDTH=""30%""><A HREF=""Notes/Notes_10/Notes_1010.htm"" TARGET = ""_top"">Website Maintenance Dashboard</A></TH>"
0195tsTextFile.WriteLine strLine
0196strLine = "</TR>"
0197tsTextFile.WriteLine strLine
0198strLine = "<TR>"
0199tsTextFile.WriteLine strLine
0200strLine = "<TH WIDTH=""30%""><A HREF=""index.htm"" TARGET = ""_top"">Return to Theo Todman's Home Page</A></TH>"
0201tsTextFile.WriteLine strLine
0202strLine = "<TH WIDTH=""40%""><A HREF=""Notes/Notes_11/Notes_1140.htm"" TARGET = ""_top"">Return to Theo Todman's Philosophy Page</A></TH>"
0203tsTextFile.WriteLine strLine
0204strLine = "<TH WIDTH=""30%"">Timestamp : <time datetime=""" & Year(Now()) & "-" & Right(Month(Now()) + 100, 2) & "-" & Right(Day(Now()) + 100, 2) & """ pubdate>" & Now() & "</time></TH>"
0205tsTextFile.WriteLine strLine
0206strLine = "</TR></TABLE></CENTER>"
0207tsTextFile.WriteLine strLine
0208 OK = CopyToTransfer(strOutputFolder, FileName)
0209Set tsTextFile = Nothing
0210End Sub

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


Source Code of: Reference_Tables
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 65
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Reference_Tables(strText, Optional Depth)
0002Dim x As Long
0003Dim Y As Long
0004Dim strCodeRef As String
0005Dim CodeRef As String
0006Dim strText_Local As String
0007Dim strText_End As String
0008Dim qryString As String
0009Dim rsTableToRead As Recordset
0010Dim iDepth As Integer
0011Dim strPrefix As String
0012Dim i As Integer
0013If Len(strText) = 0 Then
0014 Reference_Tables = "Not Found"
0015 Exit Function
0016End If
0017If IsMissing(Depth) Then
0018 iDepth = 2
0019Else
0020 iDepth = Depth
0021End If
0022i = 0
0023strPrefix = ""
0024Do While i < iDepth
0025 strPrefix = strPrefix & "../"
0026 i = i + 1
0027Loop
0028strText_Local = strText
0029x = 1
0030x = InStr(x, strText_Local, "+T")
0031Reference_Tables = "Not Found"
0032Do While x > 0
0033 Reference_Tables = "Found"
0034 Y = InStr(x + 1, strText_Local, "T+")
0035 'Watch out for false positives in finding +T
0036 If Y = 0 Then
0037 x = x + 1
0038 Else
0039 If Y - x > 100 Then
0040 x = x + 1
0041 Else
0042 strCodeRef = Mid(strText_Local, x + 2, Y - x - 2)
0043 CodeRef = Trim(strCodeRef)
0044 If Y > Len(strText_Local) - 2 Then
0045 strText_End = ""
0046 Else
0047 strText_End = Mid(strText_Local, Y + 2, Len(strText_Local))
0048 End If
0049 'Check this is indeed a Table, and provide the reference
0050 qryString = "SELECT Table_Name FROM Table_Definitions WHERE (((Table_Name)=""" & CodeRef & """));"
0051 Set rsTableToRead = CurrentDb.OpenRecordset(qryString)
0052 If Not rsTableToRead.EOF Then
0053 rsTableToRead.MoveFirst
0054 strText_Local = Left(strText_Local, x - 1) & "<A HREF = """ & strPrefix & "Documentation/Documentation_Tables_" & CodeRef & ".htm" & """>" & CodeRef & "</A>" & strText_End
0055 Else
0056 strText_Local = Left(strText_Local, x - 1) & CodeRef & strText_End
0057 x = x + 2
0058 End If
0059 Set rsTableToRead = Nothing
0060 End If
0061 End If
0062 x = InStr(x, strText_Local, "+T")
0063Loop
0064strText = strText_Local
0065End Function

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