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

Form_OpenCount_BookPapersFunctor_19Functor_21
Functor_22Functor_23Number_FormatAeon_Authors_Add
BooksToNotes_PrelimsCheckerJacks_Non_Prime.

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

Go to top of page




Source Code of: Aeon_Authors_Add
Procedure Type: Public Sub
Module: New Code
Lines of Code: 108
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Aeon_Authors_Add()
0002Dim rs As Recordset
0003Dim rsAuthors As Recordset
0004Dim rsAuthor_Parameter As Recordset
0005Dim strQuery As String
0006Dim strAuthor As String
0007Dim strAuthor_Saved As String
0008Dim Author As String
0009Dim Author_Reformat As String
0010Dim i As Integer
0011Dim j As Integer
0012Dim k As Integer
0013Dim x As Integer
0014Dim strMessage As String
0015Dim Output_Authors As Boolean
0016Dim Output_Old_Authors As Boolean
0017 strMessage = "Get ready to output Authors pages? Usually wait to output until we've output the Aeon note with 'Refresh Links', but this will maintain the Author_Parameter table."
0018If MsgBox(strMessage, vbYesNo + vbDefaultButton1) = vbYes Then
0019 Output_Authors = True
0020 strMessage = "Add all relevant Authors pages, including newly-loaded ones, to Author_Parameter table?"
0021 If MsgBox(strMessage, vbYesNo + vbDefaultButton1) = vbYes Then
0022 Output_Old_Authors = True
0023 Else
0024 Output_Old_Authors = False
0025 End If
0026Else
0027 Output_Authors = False
0028 Output_Old_Authors = False
0029End If
0030strAuthor_Saved = ""
0031' Clear & ready Author_Parameter Table
0032 strQuery = "DELETE * FROM Author_Parameter;"
0033DoCmd.RunSQL (strQuery)
0034 strQuery = "SELECT * FROM Author_Parameter;"
0035Set rsAuthor_Parameter = CurrentDb.OpenRecordset(strQuery)
0036' Select Aeon_Files rows with Authors encoded
0037 strQuery = "SELECT Aeon_Files.Author_Names FROM Aeon_Files WHERE (((Aeon_Files.Author_Names) Like ""*+A*"")) ORDER BY Aeon_Files.Author_Names;"
0038Set rs = CurrentDb.OpenRecordset(strQuery)
0039rs.MoveFirst
0040Do Until rs.EOF
0041 strAuthor = rs.Fields(0)
0042 If strAuthor <> strAuthor_Saved Then
0043 'Find the authors
0044 i = 1
0045 j = 1
0046 Do Until j = 0
0047 j = InStr(i, strAuthor, "A+")
0048 If j > 0 Then
0049 Author = Mid(strAuthor, i + 2, j - i - 2)
0050 'Check if on Author's Table
0051 strQuery = "SELECT Authors.Author_Name, Authors.Author_Name_Display FROM Authors WHERE (((Authors.Author_Name)=""" & Author & """));"
0052 Set rsAuthors = CurrentDb.OpenRecordset(strQuery)
0053 If rsAuthors.EOF Then
0054 Debug.Print Author
0055 Author_Reformat = Author
0056 x = InStr(Author_Reformat, "(")
0057 If x > 0 Then
0058 k = InStr(x, Author_Reformat, ")")
0059 If k > 0 Then
0060 Author_Reformat = Mid(Author_Reformat, x + 1, k - x - 1) & " " & Trim(Left(Author_Reformat, x - 1))
0061 End If
0062 End If
0063 'Load to Author's table
0064 rsAuthors.AddNew
0065 rsAuthors.Fields(0) = Author
0066 rsAuthors.Fields(1) = Author_Reformat
0067 rsAuthors.Update
0068 Set rsAuthors = Nothing
0069 'Add to Author_Parameter Table, ready for output of the Author pages
0070 rsAuthor_Parameter.AddNew
0071 rsAuthor_Parameter.Fields(0) = Author
0072 rsAuthor_Parameter.Update
0073 Else
0074 If Output_Old_Authors = True Then
0075 'Add to Author_Parameter Table, ready for output of the Author pages (existing authors need to have their pages updated)
0076 rsAuthor_Parameter.AddNew
0077 rsAuthor_Parameter.Fields(0) = Author
0078 On Error Resume Next
0079 rsAuthor_Parameter.Update
0080 End If
0081 End If
0082 i = j
0083 i = InStr(i, strAuthor, "+A")
0084 If i = 0 Then
0085 j = 0
0086 End If
0087 End If
0088 Loop
0089 End If
0090 strAuthor_Saved = strAuthor
0091 rs.MoveNext
0092Loop
0093If Output_Authors = True Then
0094 strMessage = "Actually output the Authors pages? Usually wait until we've output the Aeon note with 'Refresh Links'."
0095 If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0096 'Output the Author pages
0097 strDataQuery = "Authors_List_Selected_Authors"
0098 strControlTable = "Authors"
0099 strOutputFileShort = "Author"
0100 strOutputFolder = "C:\Theo's Files\Websites\Theo's Website\Authors\"
0101 strOutputFile = ""
0102 CreateAuthorsWebPages ("Regen")
0103 End If
0104End If
0105OK = MsgBox("Authors added OK at " & Now(), vbOKOnly)
0106Set rs = Nothing
0107Set rsAuthor_Parameter = Nothing
0108End Sub

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



Source Code of: BooksToNotes_Prelims
Procedure Type: Public Sub
Module: Testing
Lines of Code: 10

Line-No. / Ref.Code Line
0001Public Sub BooksToNotes_Prelims()
0002Dim strQuery As String
0003 strQuery = "DELETE * FROM Cross_Reference_Prelims;"
0004DoCmd.RunSQL (strQuery)
0005 strQuery = "BooksToNotes_Prelims_GEN"
0006DoCmd.OpenQuery (strQuery)
0007'Delete rows associated with Note 874 (Auto-Xref Test Note)
0008 strQuery = "DELETE * FROM Cross_Reference_Prelims WHERE Calling_ID = 874 AND Calling_Type = ""N"";"
0009DoCmd.RunSQL (strQuery)
0010End Sub

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



Source Code of: Checker
Procedure Type: Public Sub
Module: Testing
Lines of Code: 16

Line-No. / Ref.Code Line
0001Public Sub Checker()
0002Dim rs As Recordset
0003Dim i As Integer
0004Dim ifields As Integer
0005'Set rs = CurrentDb.OpenRecordset("TRANSFORM Sum([Year_Crosstab].[Hours ]) AS Hours SELECT Average_Plans.Project, Average_Plans.[Average This Qtr Plan] AS [Planned Weekly Hours], 0 AS [Planned QTD %age], Sum(0) AS [QTD Actual %], Round([Average YTD Plan],2) AS [Planned YTD %age], Sum(0) AS [YTD Actual %], Sum(0) AS [QTD Actual Hours], Sum(Year_Crosstab.Hours) AS [YTD Actual Hours] FROM Average_Plans LEFT JOIN Year_Crosstab ON Average_Plans.Project = Year_Crosstab.Group WHERE ((((Year_Crosstab.Period) >= ""2019-10"" And (Year_Crosstab.Period) <= ""2020-09"") Or (Year_Crosstab.Period) Is Null)) GROUP BY Average_Plans.Project, Average_Plans.[Average This Qtr Plan], Round([Average YTD Plan],2) ORDER BY Average_Plans.Project PIVOT Year_Crosstab.Period;")
0006 Set rs = CurrentDb.OpenRecordset("SELECT * FROM Project_Plans;")
0007rs.MoveFirst
0008ifields = rs.Fields.Count
0009Do Until rs.EOF
0010 For i = 0 To ifields - 1
0011 Debug.Print rs.Fields(i)
0012 Stop
0013 Next i
0014 rs.MoveNext
0015Loop
0016End Sub

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



Source Code of: Count_BookPapers
Procedure Type: Public Function
Module: New Code
Lines of Code: 13

Line-No. / Ref.Code Line
0001Public Function Count_BookPapers(strDataQuery_Saved, Author, Medium)
0002Dim rs As Recordset
0003Dim strQuery As String
0004strQuery = "SELECT Count(" & strDataQuery_Saved & ".Title) AS CountOfTitle FROM " & strDataQuery_Saved & " GROUP BY " & strDataQuery_Saved & ".Author_Name, " & strDataQuery_Saved & ".Medium HAVING (((" & strDataQuery_Saved & ".Author_Name)=""" & Author & """) AND ((" & strDataQuery_Saved & ".Medium)=""" & Medium & """));"
0005Set rs = CurrentDb.OpenRecordset(strQuery)
0006If rs.EOF Then
0007 Count_BookPapers = 0
0008Else
0009 rs.MoveLast
0010 Count_BookPapers = rs.Fields(0)
0011End If
0012Set rs = Nothing
0013End Function

Go To Top of This Page
Link to VBA Code Control Page



Source Code of: Form_Open
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 13

Line-No. / Ref.Code Line
0001Private Sub Form_Open(Cancel As Integer)
0002Dim rsTableToRead As Recordset
0003 OK = Check_Database_Size()
0004Debug.Print Now() & " - Main Database size = " & Check_Database_Size & "Mb"
0005 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT Archive_Reading_Lists, Archive_Printable_Versions, Document_Tables_Full, Document_Queries_Full FROM System_Parameters;")
0006rsTableToRead.MoveFirst
0007Archive_Reading_Lists = rsTableToRead.Fields(0).Value
0008Archive_Printable_Versions = rsTableToRead.Fields(1).Value
0009Document_Tables_Full = rsTableToRead.Fields(2).Value
0010Document_Queries_Full = rsTableToRead.Fields(3).Value
0011Full_Regen = False
0012Set rsTableToRead = Nothing
0013End Sub

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



Source Code of: Functor_19
Procedure Type: Public Function
Module: Functors
Lines of Code: 42
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor_19(Note_ID, Note_Title, Note_Text)
0002'Add jump table and record counts for Aeon Note 1292
0003Dim rs As Recordset
0004Dim strQuery As String
0005Dim Papers_Read As String
0006Dim Papers_UnReadTotal As String
0007Dim Papers_UnRead(10) As Integer
0008Dim Note_Text_Local As String
0009Dim i As Integer
0010Note_Text_Local = Note_Text
0011 strQuery = "SELECT Aeon_Files.[Read?], Count(Aeon_Files.WebRef_ID) AS CountOfWebRef_ID FROM Aeon_Files WHERE (((Aeon_Files.Aeon_Note_ID) = 1292) And ((Aeon_Files.[Exclude?]) = False)) GROUP BY Aeon_Files.[Read?];"
0012Set rs = CurrentDb.OpenRecordset(strQuery)
0013If Not rs.EOF Then
0014 rs.MoveFirst
0015 Papers_Read = rs.Fields(1)
0016 OK = Number_Format(Papers_Read)
0017 rs.MoveLast
0018 Papers_UnReadTotal = rs.Fields(1)
0019 OK = Number_Format(Papers_UnReadTotal)
0020End If
0021 strQuery = "SELECT Aeon_Files.Priority, Count(Aeon_Files.WebRef_ID) AS CountOfWebRef_ID FROM Aeon_Files WHERE (((Aeon_Files.Aeon_Note_ID) = 1292) And ((Aeon_Files.[Read?]) = False) AND ((Aeon_Files.[Exclude?])=False)) GROUP BY Aeon_Files.Priority ORDER BY Aeon_Files.Priority;"
0022Set rs = CurrentDb.OpenRecordset(strQuery)
0023If Not rs.EOF Then
0024 rs.MoveFirst
0025 Do Until rs.EOF
0026 Papers_UnRead(rs.Fields(0)) = rs.Fields(1)
0027 rs.MoveNext
0028 Loop
0029End If
0030Note_Text_Local = "<br><CENTER><TABLE class = ""ReadingList"" WIDTH=1200><TR>"
0031Note_Text_Local = Note_Text_Local & "<TD class = ""BridgeLeft""> <a href=""#Off-Page_Link_Project_Note_1292_Intro""><B>Introduction</a></B></TD>"
0032Note_Text_Local = Note_Text_Local & "<TD class = ""BridgeLeft""> <a href=""#Off-Page_Link_Project_Note_1292_Read""><B>Papers Read</a>: </B>" & Papers_Read & "</TD>"
0033Note_Text_Local = Note_Text_Local & "<TD class = ""BridgeLeft""> <B>Papers Unread: " & Papers_UnReadTotal & "</B> &rarr; </TD>"
0034For i = 0 To 10
0035 If Papers_UnRead(i) > 0 Then
0036 Note_Text_Local = Note_Text_Local & "<TD class = ""BridgeLeft""> <a href=""#Off-Page_Link_Project_Note_1292_Pri_" & i & """><B>Pri " & i & "</B></a>: " & Papers_UnRead(i) & "</TD>"
0037 End If
0038Next i
0039Note_Text_Local = Note_Text_Local & "</TR></TABLE></CENTER><a name=""Off-Page_Link_Project_Note_1292_Intro""></a>"
0040Note_Text = Note_Text_Local
0041Functor_19 = "Yes"
0042End Function

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



Source Code of: Functor_21
Procedure Type: Public Function
Module: Functors
Lines of Code: 264
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor_21(strParameter, strTable)
0002'This function formats a web-table from a Cross-tab query
0003Dim rs As Recordset
0004Dim i As Integer
0005Dim j As Long
0006Dim k(100)
0007Dim iRows As Integer
0008Dim iCols As Integer
0009Dim strTable_Local As String
0010Dim strElement As String
0011Dim strCell As String
0012Dim strCell_1_Saved As String
0013Dim strCell_4_Saved As String
0014Dim strQuery As String
0015Dim strHeader As String
0016Dim iTotal_Col As Integer
0017Select Case strParameter
0018 Case 1
0019 strQuery = "Cross_Reference_By_Type"
0020 iTotal_Col = 0
0021 Case 2
0022 strQuery = "Cross_Reference_Changes_By_Type"
0023 iTotal_Col = 0
0024 Case 3
0025 strQuery = "Oboe_Practice_Hours_List"
0026 iTotal_Col = 0
0027 Case 4
0028 strQuery = "Auto_Ref_Notes_Stats_Summary"
0029 iTotal_Col = 4
0030 Case 5
0031 iTotal_Col = 5
0032 strQuery = "Auto_Ref_Notes_Stats_Detailed"
0033 Case 6
0034 iTotal_Col = 6 'Dummy
0035 strQuery = "Functor_Calls"
0036 Case 7
0037 Find_Functors
0038 iTotal_Col = 6 'Dummy
0039 strQuery = "Functors_FbyN"
0040 Case 8
0041 Find_Functors
0042 iTotal_Col = 6 'Dummy
0043 strQuery = "Functors_NbyF"
0044 Case 9
0045 strQuery = "Auto_Ref_Notes_Stats_Grand_Summary"
0046 iTotal_Col = 5
0047 Case 10
0048 strQuery = "Auto_Ref_Notes_Stats_Grandest_Summary"
0049 iTotal_Col = 4
0050 Case 11
0051 'Ready some stats!
0052 strQuery = "DELETE * FROM Temp_Lang_Date_Last_Study;"
0053 DoCmd.RunSQL (strQuery)
0054 strQuery = "Temp_Lang_Date_Last_Study_GEN"
0055 DoCmd.OpenQuery (strQuery)
0056 strQuery = "Language_Location_Primer_Date_Time_Updt"
0057 DoCmd.OpenQuery (strQuery)
0058 strQuery = "Language_Animadversions_List"
0059 iTotal_Col = 6
0060 Case 12
0061 strQuery = "Language_Animadversions_XTab"
0062 iTotal_Col = 50
0063 Case 13
0064 strQuery = "Language_Animadversions_XTab_Pri2"
0065 iTotal_Col = 50
0066 Case Else
0067 Exit Function
0068End Select
0069strTable_Local = ""
0070j = 0
0071For i = 1 To 100
0072 k(i) = 0
0073Next i
0074Set rs = CurrentDb.OpenRecordset(strQuery)
0075If rs.EOF Then
0076 Debug.Print Now(); " - Functor_21 - " & strQuery; " : No table to print"
0077 Functor_21 = "No"
0078 Exit Function
0079Else
0080 rs.MoveLast
0081 iRows = rs.RecordCount
0082 iCols = rs.Fields.Count
0083 If iTotal_Col = 0 Then
0084 iTotal_Col = iCols
0085 End If
0086 rs.MoveFirst
0087End If
0088'Set up Table Header
0089Select Case strParameter
0090 Case 3
0091 strElement = "<table width=1500 class = ""Bridge"">"
0092 Case 7, 8
0093 strElement = "<table width=700 class = ""ReadingList"">"
0094 Case 11
0095 strElement = "<table width=1200 class = ""ReadingList"">"
0096 Case 12, 13
0097 strElement = "<table width=1200 class = ""Bridge"">"
0098 Case Else
0099 strElement = "<table width=900 class = ""Bridge"">"
0100End Select
0101strTable_Local = strTable_Local & strElement
0102'Set up Table Headings
0103strElement = "<tr>"
0104For i = 1 To iCols
0105 strCell = rs.Fields(i - 1).Name
0106 Select Case strParameter
0107 Case 7
0108 If i = 1 Or i = 4 Then
0109 strElement = strElement & "<th class = ""BridgeLeft"">" & strCell & "</th>"
0110 Else
0111 strElement = strElement & "<th class = ""BridgeCenter"">" & strCell & "</th>"
0112 End If
0113 Case 8
0114 If i = 1 Or i = 2 Then
0115 strElement = strElement & "<th class = ""BridgeLeft"">" & strCell & "</th>"
0116 Else
0117 strElement = strElement & "<th class = ""BridgeCenter"">" & strCell & "</th>"
0118 End If
0119 Case 11
0120 If i = 4 Then
0121 strElement = strElement & "<th class = ""BridgeLeft"">" & strCell & "</th>"
0122 Else
0123 strElement = strElement & "<th class = ""BridgeCenter"">" & strCell & "</th>"
0124 End If
0125 Case Else
0126 strElement = strElement & "<th>" & strCell & "</th>"
0127 End Select
0128 If i = iTotal_Col And strParameter <> 3 Then
0129 strElement = strElement & "<th>TOTAL</th>"
0130 End If
0131Next i
0132strElement = strElement & "</tr>"
0133strHeader = strElement
0134strTable_Local = strTable_Local & strElement
0135'Set up Table Rows
0136strCell_1_Saved = ""
0137strCell_4_Saved = ""
0138strElement = ""
0139Do Until rs.EOF
0140 If strParameter = 11 Then
0141 If (strCell_1_Saved <> rs.Fields(0)) And (strCell_1_Saved <> "") Then
0142 'Insert a blank row
0143 strElement = strElement & "<tr>"
0144 For i = 1 To iCols
0145 strElement = strElement & "<td>&nbsp;</td>"
0146 Next i
0147 strElement = strElement & "</tr>"
0148 End If
0149 End If
0150 strElement = strElement & "<tr>"
0151 j = 0
0152 For i = 1 To iCols
0153 Select Case i
0154 Case 1
0155 strCell = rs.Fields(0)
0156 If strParameter = 7 Or strParameter = 8 Or strParameter = 11 Then
0157 If strCell_1_Saved = strCell Then
0158 strCell = "&uarr;&uarr;&uarr;"
0159 Else
0160 strCell_1_Saved = strCell
0161 If strParameter = 11 Then
0162 strCell = "+R" & strCell & "R+" & "<b>" & strCell & "</b>"
0163 End If
0164 End If
0165 If strParameter = 11 And rs.Fields(1) <> 0 Then
0166 strCell = "+R" & rs.Fields(1) & "R+ " & strCell
0167 End If
0168 strElement = strElement & "<td class = ""BridgeLeft"">" & strCell & "</td>"
0169 Else
0170 strElement = strElement & "<td>" & strCell & "</td>"
0171 End If
0172 Case Else
0173 strCell = rs.Fields(i - 1) & ""
0174 If strCell = "" Then
0175 strCell = "&nbsp;"
0176 Else
0177 If i <= iTotal_Col Then
0178 j = j + Val(strCell)
0179 End If
0180 k(i) = k(i) + Val(strCell)
0181 If strParameter <> 3 Then
0182 OK = Number_Format(strCell)
0183 End If
0184 End If
0185 If i = 4 And strParameter = 7 Then
0186 If strCell_4_Saved = strCell Then
0187 strCell = "&uarr;&uarr;&uarr;"
0188 Else
0189 strCell_4_Saved = strCell
0190 End If
0191 End If
0192 If (strParameter = 7 And i < 4) Or (strParameter = 8 And i > 2) Or (strParameter = 11 And i < 4) Then
0193 strElement = strElement & "<td class=""BridgeCenter"">" & strCell & "</td>"
0194 Else
0195 If strParameter = 11 And i = 4 Then
0196 If rs.Fields(1) = "0" Then
0197 strCell = strCell & ": " & Language_Animadversion_Reference_List(rs.Fields(0))
0198 'Add old time
0199 strCell = Subject_Hours_List(rs.Fields(0)) & strCell
0200 Else
0201 strCell = Language_Animadversion_Translate(strCell, rs.Fields(0))
0202 End If
0203 End If
0204 If (strParameter = 7 And i = 4) Or (strParameter = 8 And i = 2) Or (strParameter = 11 And i = 4) Then
0205 strElement = strElement & "<td class=""BridgeLeft"">" & strCell & "</td>"
0206 Else
0207 strElement = strElement & "<td format="","">" & strCell & "</td>"
0208 End If
0209 End If
0210 If i = iTotal_Col Then
0211 'Row Total
0212 strCell = j
0213 If strParameter <> 3 Then
0214 OK = Number_Format(strCell)
0215 strElement = strElement & "<th>" & strCell & "</th>"
0216 End If
0217 k(iCols + 1) = k(iCols + 1) + j
0218 End If
0219 End Select
0220 Next i
0221 strElement = strElement & "</tr>"
0222 rs.MoveNext
0223Loop
0224strTable_Local = strTable_Local & strElement
0225'Set up Total Line
0226If iCols >= iTotal_Col Then 'Allow for no Total Row
0227 strElement = "<tr><th>TOTAL</th>"
0228 For i = 2 To iCols
0229 strCell = k(i)
0230 If strParameter <> 3 Then
0231 OK = Number_Format(strCell)
0232 End If
0233 If strCell = 0 Then
0234 strCell = "&nbsp;"
0235 End If
0236 If strParameter = 3 Then
0237 If i < 5 Then
0238 strElement = strElement & "<th>" & "&nbsp;" & "</th>"
0239 Else
0240 strElement = strElement & "<th>" & strCell & "</th>"
0241 End If
0242 Else
0243 strElement = strElement & "<th>" & strCell & "</th>"
0244 If i = iTotal_Col Then
0245 strCell = k(iCols + 1)
0246 OK = Number_Format(strCell)
0247 strElement = strElement & "<th>" & strCell & "</th>"
0248 End If
0249 End If
0250 Next i
0251 strElement = strElement & "<tr>"
0252 strTable_Local = strTable_Local & strElement
0253End If
0254'Set up Table Footer
0255If strParameter = 3 Then
0256 strTable_Local = strTable_Local & strHeader 'Repeat the column headers
0257End If
0258strElement = "</table>"
0259strTable_Local = strTable_Local & strElement
0260'Tidy up and exit
0261Functor_21 = "Yes"
0262strTable = strTable_Local
0263Set rs = Nothing
0264End Function

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



Source Code of: Functor_22
Procedure Type: Public Function
Module: Functors
Lines of Code: 51
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor_22(strParameter, strList)
0002'This function formats a list (together with surrounding narrative) from a query
0003Dim rs As Recordset
0004Dim strList_Local As String
0005Dim strElement As String
0006Dim strCell As String
0007Dim strQuery As String
0008Select Case strParameter
0009 Case 1
0010 strQuery = "Cross_Reference_By_Year"
0011 strElement = "However, there are (as of " & Now() & ", using +CFunctor_22C+ & query +QCross_Reference_By_YearQ+) the following counts of records on the table with timestamps in the years below:- "
0012 Case 2
0013 strQuery = "Cross_Reference_Changes_By_Year"
0014 strElement = ""
0015 Case 3
0016 DoCmd.OpenQuery ("Functor_Descriptions_GEN")
0017 strQuery = "Functor_Descriptions_List"
0018 strElement = ""
0019 Case 4
0020 strQuery = "Cross_Reference_Changes_By_Month"
0021 strElement = ""
0022End Select
0023Set rs = CurrentDb.OpenRecordset(strQuery)
0024strList_Local = ""
0025If rs.EOF Then
0026 Debug.Print Now(); "Functor_22: Option " & strParameter & " - No list to print"
0027 Functor_22 = "No"
0028 Exit Function
0029Else
0030 rs.MoveFirst
0031End If
0032'Set up List Header
0033strElement = strElement & "|##|"
0034strList_Local = strList_Local & strElement
0035strElement = ""
0036Do Until rs.EOF
0037 strElement = strElement & "|.|"
0038 strElement = strElement & "<b>" & rs.Fields(0) & "</b>: "
0039 strCell = rs.Fields(1)
0040 OK = Number_Format(strCell)
0041 strElement = strElement & strCell
0042 rs.MoveNext
0043Loop
0044strList_Local = strList_Local & strElement
0045'Set up End List
0046strElement = "|##|"
0047strList_Local = strList_Local & strElement
0048Functor_22 = "Yes"
0049strList = strList_Local
0050Set rs = Nothing
0051End Function

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



Source Code of: Functor_23
Procedure Type: Public Function
Module: Functors
Lines of Code: 118
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor_23(Note_ID, strOption, strValue)
0002'This function returns a value (together with surrounding narrative) from a query
0003Dim rs As Recordset
0004Dim strValue_Local As String
0005Dim strElement As String
0006Dim strMsg As String
0007Dim strQuery As String
0008Dim Field_1 As String
0009Dim Field_2 As String
0010Dim Field_3 As String
0011Select Case strOption
0012 Case "1"
0013 strQuery = "Dud_Cross_References_This_Year"
0014 Case "2"
0015 strQuery = "Cross_Reference_MaxID"
0016 Case "3"
0017 strQuery = "SELECT Count(Cross_Reference_Changes.ID) AS CountOfID FROM Cross_Reference_Changes;"
0018 Case "4"
0019 strQuery = "SELECT Website_Regen_Control.Regen_Mins, Website_Regen_Control.Last_Run, Website_Regen_Control.Division FROM Website_Regen_Control WHERE (((Website_Regen_Control.Division)=""Paper_Abstract_Ranges""));"
0020 Case "5"
0021 strQuery = "SELECT Website_Regen_Control.Regen_Mins, Website_Regen_Control.Last_Run, Website_Regen_Control.Division FROM Website_Regen_Control WHERE (((Website_Regen_Control.Division)=""Author_Letters""));"
0022 Case "6"
0023 strQuery = "SELECT Website_Regen_Control.Regen_Mins, Website_Regen_Control.Last_Run, Website_Regen_Control.Division FROM Website_Regen_Control WHERE (((Website_Regen_Control.Division)=""BookPaperAbstract_Ranges""));"
0024 Case "7"
0025 strQuery = "SELECT Website_Regen_Control.Regen_Mins, Website_Regen_Control.Last_Run, Website_Regen_Control.Division FROM Website_Regen_Control WHERE (((Website_Regen_Control.Division)=""Note_Regen_Ranges""));"
0026 Case "8"
0027 strQuery = "SELECT Website_Regen_Control.Regen_Mins, Website_Regen_Control.Last_Run, Website_Regen_Control.Division FROM Website_Regen_Control WHERE (((Website_Regen_Control.Division)=""Note_Archive_Regen_Ranges""));"
0028 Case "9"
0029 strQuery = "SELECT * FROM Oboe_Latest_Lesson;"
0030 Case "10"
0031 strQuery = "SELECT BookPaperControl.Time_To_Regenerate, BookPaperControl.Latest_Update FROM BookPaperControl WHERE (((BookPaperControl.[ID])=""Auto_Reference_Notes_Regen""));"
0032 Case "11"
0033 strQuery = "Hits_Pages_Totals"
0034 Case "12"
0035 strQuery = "Hits_Pages_Totals_LastYear"
0036 Case "13"
0037 strQuery = "SELECT Count(Site_Map.Size) AS Records, Max([Timestamp_Logged]) AS [As At] FROM Site_Map;"
0038 Case "14"
0039 strQuery = "SELECT Website_Regen_Control.Regen_Mins, Website_Regen_Control.Last_Run, Website_Regen_Control.Division FROM Website_Regen_Control WHERE (((Website_Regen_Control.Division)=""Book_Summary_Ranges""));"
0040 Case "15"
0041 strQuery = "Earliest_Lang_Dates"
0042 Case Else
0043 Debug.Print Now(); "Note: " & Note_ID & ". Functor_23 : Invalid Option : " & strOption
0044 Functor_23 = "No"
0045 Exit Function
0046End Select
0047Set rs = CurrentDb.OpenRecordset(strQuery)
0048strValue_Local = ""
0049If rs.EOF Then
0050 Debug.Print Now(); "Note: " & Note_ID & ". Functor_23 : No item to print (Option = " & strOption & ")"
0051 Functor_23 = "No"
0052 Exit Function
0053End If
0054Select Case strOption
0055 Case "1"
0056 rs.MoveLast
0057 strElement = rs.Fields(1)
0058 If rs.Fields(0) <> rs.Fields(2) Then
0059 strElement = 0
0060 End If
0061 If strElement = 0 Then
0062 strElement = "no"
0063 strMsg = "encouraging."
0064 Else
0065 strMsg = "<b>worrying. <u>Investigate</u>!</b>"
0066 Debug.Print Now(); "Note: " & Note_ID & ". Functor_23, Option 1 : Non-zero value printed - Investigate!"
0067 End If
0068 strValue_Local = strElement & " record" & IIf(Val(strElement) > 1, "s", "") & " for " & rs.Fields(2) & " prior to the " & rs.Fields(3) & " regeneration, which is " & strMsg
0069 Case "2"
0070 rs.MoveFirst
0071 strElement = rs.Fields(0)
0072 OK = Number_Format(strElement)
0073 strValue_Local = Now() & " it is " & strElement & " - but it's taken " & Year(Now) - 2015
0074 Case "3"
0075 rs.MoveFirst
0076 strElement = rs.Fields(0)
0077 OK = Number_Format(strElement)
0078 strValue_Local = strElement & " rows, as of " & Left(Now(), 10) & ", "
0079 Case "4", "5", "6", "7", "8", "10", "14"
0080 rs.MoveFirst
0081 strElement = rs.Fields(0)
0082 If strElement >= 60 Then
0083 strElement = Round(strElement / 60, 2) & " hours"
0084 Else
0085 strElement = strElement & " minutes"
0086 End If
0087 strElement = strElement & " on " & Left(rs.Fields(1), 10)
0088 strValue_Local = strElement
0089 Case "9"
0090 rs.MoveFirst
0091 strValue_Local = rs.Fields(0)
0092 Case "11", "12"
0093 rs.MoveFirst
0094 Field_1 = rs.Fields(0) 'Min period recorded
0095 Field_2 = rs.Fields(1) 'Max period recorded
0096 Field_3 = rs.Fields(2) 'Total Hits
0097 Field_1 = Left(Field_1, 4) * 12 + Right(Field_1, 2)
0098 Field_2 = Left(Field_2, 4) * 12 + Right(Field_2, 2)
0099 Field_1 = Field_2 - Field_1 + 1
0100 Field_2 = Field_1 * 365 / 12
0101 Field_3 = Round(Field_3 / Field_2 / 1000, 1)
0102 strValue_Local = Field_3 & "k or so hits a day over the " & Field_1 & " months up to " & rs.Fields(1)
0103 Case "13"
0104 rs.MoveFirst
0105 strValue_Local = Round(rs.Fields(0) / 1000, 0) & "k pages on my site as at " & Left(rs.Fields(1), 10)
0106 Case "15"
0107 rs.MoveFirst
0108 strValue_Local = "Next languages in the queue are:- |..|"
0109 Do Until rs.EOF
0110 strValue_Local = strValue_Local & "|.|<b>Priority " & rs.Fields(0) & ": " & rs.Fields(1) & "</b>. Last studied on " & Format(rs.Fields(2), "Long Date")
0111 rs.MoveNext
0112 Loop
0113 strValue_Local = strValue_Local & "|..|"
0114End Select
0115Functor_23 = "Yes"
0116strValue = strValue_Local
0117Set rs = Nothing
0118End Function

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



Source Code of: Jacks_Non_Prime
Procedure Type: Public Sub
Module: Testing
Lines of Code: 36
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Jacks_Non_Prime()
0002'Prove that 2^10 + 5^12 is non-prime
0003'The program shows:-
0004'... The number is 244,141,649 = 14657 x 16657
0005'... Max Long is 2,147,483,647, so didn't need LongLong
0006Dim Non_Prime As LongLong
0007Dim Non_Prime_Temp As LongLong
0008Dim Non_Prime_Sqrt As Integer
0009Dim i As Integer
0010Non_Prime_Temp = 1
0011For i = 1 To 10
0012 Non_Prime_Temp = Non_Prime_Temp * 2
0013Next i
0014Debug.Print Non_Prime_Temp
0015Non_Prime = Non_Prime_Temp
0016Non_Prime_Temp = 1
0017For i = 1 To 12
0018 Non_Prime_Temp = Non_Prime_Temp * 5
0019Next i
0020Debug.Print Non_Prime_Temp
0021Non_Prime = Non_Prime + Non_Prime_Temp
0022Debug.Print Non_Prime
0023Non_Prime_Sqrt = Non_Prime ^ 0.5
0024Debug.Print Non_Prime_Sqrt
0025Non_Prime_Sqrt = Non_Prime_Sqrt / 2 + 1
0026For i = 1 To Non_Prime_Sqrt
0027 Non_Prime_Temp = Non_Prime Mod (2 * i + 1)
0028 If Non_Prime_Temp = 0 Then
0029 Debug.Print 2 * i + 1
0030 Non_Prime_Temp = Non_Prime / (2 * i + 1)
0031 Debug.Print Non_Prime_Temp
0032 Non_Prime_Temp = Non_Prime_Temp * (2 * i + 1)
0033 Debug.Print Non_Prime_Temp
0034 End If
0035Next i
0036End Sub

Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page



Source Code of: Number_Format
Procedure Type: Public Function
Module: New Code
Lines of Code: 39
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Number_Format(strNumber_Sent)
0002Dim strNumber_Local As String
0003Dim Digit_Table(20) As String
0004Dim i As Integer
0005Dim j As Integer
0006Dim iLen_Number As Integer
0007'This function inserts commas into a number sent ...
0008'I may get it to do further functions in due course
0009' .... I couldn't find an HTML format command to do this
0010' .... but there must be a VBA built-in function?
0011strNumber_Local = Trim(strNumber_Sent)
0012If Not IsNumeric(strNumber_Local) Then
0013 Exit Function
0014End If
0015iLen_Number = Len(strNumber_Local)
0016For i = 1 To 20
0017 Digit_Table(i) = ""
0018Next i
0019'Add the commas (in reverse)
0020j = 1
0021For i = 1 To iLen_Number
0022 Digit_Table(j) = Mid(strNumber_Local, iLen_Number + 1 - i, 1)
0023 j = j + 1
0024 If i Mod 3 = 0 Then
0025 Digit_Table(j) = ","
0026 j = j + 1
0027 End If
0028Next i
0029'Remove trailing comma
0030If Digit_Table(j - 1) = "," Then
0031 Digit_Table(j - 1) = ""
0032End If
0033strNumber_Local = ""
0034For i = 1 To j - 1
0035 strNumber_Local = strNumber_Local & Digit_Table(j - i)
0036Next i
0037'Exit
0038strNumber_Sent = strNumber_Local
0039End Function

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



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