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

Sub_Function_Call_CheckerCode_DocumenterDocumentation_GeneratorMonthly_Report_Note980_Update

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

Go to top of page



Source Code of: Code_Documenter
Procedure Type: Public Sub
Module: Documentation
Lines of Code: 172
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Code_Documenter()
0002Dim x As Integer
0003Dim i As Integer
0004Dim j As Integer
0005Dim k As Integer
0006Dim m As Integer
0007Dim n As Integer
0008Dim p As Integer
0009Dim q As Integer
0010Dim r As Integer
0011Dim s As Integer
0012Dim Y As Modules
0013Dim a As String
0014Dim d As String
0015Dim e As String
0016Dim f As String
0017Dim z As String
0018Dim rsTableToRead As Recordset
0019q = 1
0020'Ready the Code Table
0021If Code_Links_Regeneration = False Then
0022 DoCmd.RunSQL ("DELETE Code_Table.* FROM Code_Table;")
0023 Set rsTableToRead = CurrentDb.OpenRecordset("Select Code_Table.* FROM Code_Table;")
0024End If
0025'Ready the Code & Code Links Tables
0026If Code_Links_Regeneration = True Then
0027 DoCmd.RunSQL ("DELETE Code_Links_Table.* FROM Code_Links_Table;")
0028 Set rsCodeLinksDB = CurrentDb.OpenRecordset("Select Code_Links_Table.* FROM Code_Links_Table;")
0029 Set rsCodeDB = CurrentDb.OpenRecordset("Select Code_Table.* FROM Code_Table ORDER BY Procedure_Name;")
0030End If
0031'Read Union of Query Names, Query_Name_Fragments and Table Names for subsequent checking
0032'... Sorted into decending order of length (so that shorter Object names that are part of longer ones don't get selected as false positives
0033 Set rsQueryDB = CurrentDb.OpenRecordset("Select Query_Definitions.Query_Name, ""Q"", Query_Definitions.Query_Type, Len([Query_Definitions.Query_Name]) AS Expr1 FROM Query_Definitions UNION ALL Select Query_Name_Fragment_List.Query_Name_Fragment, ""F"", """", Len([Query_Name_Fragment_List.Query_Name_Fragment]) AS Expr1 FROM Query_Name_Fragment_List UNION ALL Select Table_Definitions.Table_Name, ""T"", """", Len([Table_Definitions.Table_Name]) AS Expr1 FROM Table_Definitions ORDER BY Expr1 DESC;")
0034'Ready the Query Links Tables
0035 DoCmd.RunSQL ("DELETE Query_Links_Table.*, Query_Links_Table.Object_1_Type FROM Query_Links_Table WHERE Query_Links_Table.Object_1_Type = ""C"";")
0036 Set rsQueryLinksDB = CurrentDb.OpenRecordset("Select Query_Links_Table.* FROM Query_Links_Table;")
0037Set Y = Application.Modules
0038x = Y.Count
0039For i = 0 To x - 1
0040 'New Module
0041 a = Y(i).Name
0042 n = Y(i).CountOfLines
0043 For j = 1 To n
0044 'New Line
0045 z = Y(i).Lines(j, 1)
0046 If Trim(z) = "" Then
0047 Else
0048 If InStr(z, "Public Sub ") > 0 Then
0049 k = Len("Public Sub")
0050 r = InStr(z, "(")
0051 s = InStr(z, ")")
0052 e = Trim(Mid(z, k + 1, r - k - 1))
0053 f = Trim(Mid(z, r + 1, s - r - 1))
0054 m = 0
0055 d = "0001 " & z & Chr$(10)
0056 p = 1
0057 Do Until m > 0
0058 j = j + 1
0059 z = Y(i).Lines(j, 1)
0060 If Trim(z) & "" <> "" Then
0061 p = p + 1
0062 If Trim(z) = "End Sub" Then
0063 m = 1
0064 Else
0065 m = 0
0066 End If
0067 d = d & Right(10000 + p, 4) & " " & z & Chr$(10)
0068 End If
0069 Loop
0070 If Code_Links_Regeneration = True Then
0071 'Check for sub/function calls & Query / Table usage
0072 OK = Sub_Function_Call_Checker(e, d)
0073 OK = Query_Use_Checker(e, "C", d)
0074 Else
0075 'Add Code Record
0076 rsTableToRead.AddNew
0077 rsTableToRead.Fields(0) = e
0078 rsTableToRead.Fields(1) = "Public Sub"
0079 rsTableToRead.Fields(2) = a
0080 rsTableToRead.Fields(3) = d
0081 rsTableToRead.Fields(4) = p
0082 rsTableToRead.Fields(5) = q
0083 rsTableToRead.Fields(7) = f
0084 rsTableToRead.Update
0085 q = q + 1
0086 End If
0087 Else
0088 If InStr(z, "Public Function ") > 0 Then
0089 k = Len("Public Function")
0090 r = InStr(z, "(")
0091 s = InStr(z, ")")
0092 e = Trim(Mid(z, k + 1, r - k - 1))
0093 f = Trim(Mid(z, r + 1, s - r - 1))
0094 m = 0
0095 d = "0001 " & z & Chr$(10)
0096 p = 1
0097 Do Until m > 0
0098 j = j + 1
0099 z = Y(i).Lines(j, 1)
0100 If Trim(z) & "" <> "" Then
0101 p = p + 1
0102 If Trim(z) = "End Function" Then
0103 m = 1
0104 Else
0105 m = 0
0106 End If
0107 d = d & Right(10000 + p, 4) & " " & z & Chr$(10)
0108 End If
0109 Loop
0110 If Code_Links_Regeneration = True Then
0111 'Check for sub/function calls & Query / Table usage
0112 OK = Sub_Function_Call_Checker(e, d)
0113 OK = Query_Use_Checker(e, "C", d)
0114 Else
0115 'Add Code Record
0116 rsTableToRead.AddNew
0117 rsTableToRead.Fields(0) = e
0118 rsTableToRead.Fields(1) = "Public Function"
0119 rsTableToRead.Fields(2) = a
0120 rsTableToRead.Fields(3) = d
0121 rsTableToRead.Fields(4) = p
0122 rsTableToRead.Fields(5) = q
0123 rsTableToRead.Fields(7) = f
0124 rsTableToRead.Update
0125 q = q + 1
0126 End If
0127 Else
0128 If InStr(z, "Private Sub") > 0 Then
0129 k = Len("Private Sub")
0130 e = Trim(Mid(z, k + 1, InStr(z, "(") - k - 1))
0131 m = 0
0132 d = "0001 " & z & Chr$(10)
0133 p = 1
0134 Do Until m > 0
0135 j = j + 1
0136 z = Y(i).Lines(j, 1)
0137 If Trim(z) & "" <> "" Then
0138 p = p + 1
0139 If Trim(z) = "End Sub" Then
0140 m = 1
0141 Else
0142 m = 0
0143 End If
0144 d = d & Right(10000 + p, 4) & " " & z & Chr$(10)
0145 End If
0146 Loop
0147 If Code_Links_Regeneration = True Then
0148 'Check for sub/function calls & Query / Table usage
0149 OK = Sub_Function_Call_Checker(e, d)
0150 OK = Query_Use_Checker(e, "C", d)
0151 Else
0152 'Add Code Record
0153 rsTableToRead.AddNew
0154 rsTableToRead.Fields(0) = e
0155 rsTableToRead.Fields(1) = "Private Sub"
0156 rsTableToRead.Fields(2) = a
0157 rsTableToRead.Fields(3) = d
0158 rsTableToRead.Fields(4) = p
0159 rsTableToRead.Fields(5) = q
0160 rsTableToRead.Update
0161 q = q + 1
0162 End If
0163 End If
0164 End If
0165 End If
0166 End If
0167 Next j
0168Next i
0169Set rsTableToRead = Nothing
0170Set rsCodeLinksDB = Nothing
0171Set rsCodeDB = Nothing
0172End Sub

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


Source Code of: Documentation_Generator
Procedure Type: Public Sub
Module: Documentation
Lines of Code: 120
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Documentation_Generator()
0002Dim qdfLoop As QueryDef
0003Dim tdfLoop As TableDef
0004Dim rsTableToRead As Recordset
0005Dim rsDocumentationControl As Recordset
0006Dim rsQueryControl As Recordset
0007Dim rsQueryDefs As Recordset
0008Dim start As Date
0009Dim Duration As Single
0010start = Now()
0011'Delete the old files
0012If Document_Tables_Full = True And Document_Queries_Full = True Then
0013 OK = ZapFiles(TheoWebsiteRoot & "\Documentation", "Documentation")
0014End If
0015'Find when last run (why needed?)
0016 Set rsDocumentationControl = CurrentDb.OpenRecordset("Select Documentation_Control.* FROM Documentation_Control;")
0017rsDocumentationControl.MoveFirst
0018Documentation_Last_Run = rsDocumentationControl.Fields(0).Value
0019'Archive QueryDefs before regenerating
0020 DoCmd.OpenQuery ("Query_Definitions_Archive")
0021'Regenerate QueryDefs Table
0022 DoCmd.RunSQL ("DELETE Query_Definitions.* FROM Query_Definitions;")
0023 Set rsTableToRead = CurrentDb.OpenRecordset("Select Query_Definitions.* FROM Query_Definitions;")
0024For Each qdfLoop In CurrentDb.QueryDefs
0025 If Left(qdfLoop.Name, 1) <> "~" Then
0026 rsTableToRead.AddNew
0027 rsTableToRead.Fields(0) = qdfLoop.Name
0028 rsTableToRead.Fields(1) = qdfLoop.Type
0029 rsTableToRead.Fields(2) = qdfLoop.DateCreated
0030 rsTableToRead.Fields(3) = qdfLoop.LastUpdated
0031 rsTableToRead.Fields(4) = qdfLoop.Sql
0032 rsTableToRead.Update
0033 End If
0034Next qdfLoop
0035'Check for re-used query-names
0036 Set rsQueryDefs = CurrentDb.OpenRecordset("ReusedQueryNames")
0037If Not rsQueryDefs.EOF Then
0038 rsQueryDefs.MoveFirst
0039 NoReusedQueryNames = rsQueryDefs.RecordCount
0040 DoCmd.OpenQuery ("ReusedQueryNames")
0041End If
0042'Re-create Query_Name_Fragments table
0043 Query_Name_Fragments_GEN
0044'Regenerate TableDefs Table
0045 DoCmd.RunSQL ("DELETE Table_Definitions.* FROM Table_Definitions;")
0046 Set rsTableToRead = CurrentDb.OpenRecordset("Select Table_Definitions.* FROM Table_Definitions;")
0047For Each tdfLoop In CurrentDb.TableDefs
0048 If Left(tdfLoop.Name, 1) <> "~" Then
0049 rsTableToRead.AddNew
0050 rsTableToRead.Fields(0) = tdfLoop.Name
0051 rsTableToRead.Fields(1) = tdfLoop.RecordCount
0052 rsTableToRead.Fields(2) = tdfLoop.DateCreated
0053 rsTableToRead.Fields(3) = tdfLoop.LastUpdated
0054 rsTableToRead.Fields(4) = tdfLoop.Connect
0055 rsTableToRead.Update
0056 End If
0057Next tdfLoop
0058 Linked_Table_Counts
0059Set rsTableToRead = Nothing
0060'Regenerate Query Links Table
0061 Query_Documenter
0062'Regenerate Code Table
0063Code_Links_Regeneration = False
0064 Code_Documenter
0065'Assign Code Locations to ...
0066' Old Procedures
0067 DoCmd.OpenQuery ("Code_Location_Update")
0068' New Procedures
0069 Code_Location_Assignment
0070'Check variables used in code ...
0071 Check_Variables
0072'Regenerate Code Links Table
0073Code_Links_Regeneration = True
0074 Code_Documenter
0075'Create the Web Pages
0076 CreateDocumentationWebPages
0077'Save any Procedures changed (or new) since last run ...
0078 Code_Archive
0079'Warnings re unused Queries & Variables, and unused / redundant Images
0080 Set rsQueryControl = CurrentDb.OpenRecordset("Ambiguous_Objects")
0081If Not rsQueryControl.EOF Then
0082 DoCmd.OpenQuery ("Ambiguous_Objects")
0083 NoAmbiguousNames = rsQueryControl.RecordCount
0084End If
0085 Set rsQueryControl = CurrentDb.OpenRecordset("Unused_Queries")
0086If Not rsQueryControl.EOF Then
0087 DoCmd.OpenQuery ("Unused_Queries")
0088 NoUnusedQueries = rsQueryControl.RecordCount
0089End If
0090 Set rsQueryDefs = CurrentDb.OpenRecordset("Unused_Variables")
0091If Not rsQueryDefs.EOF Then
0092 DoCmd.OpenQuery ("Unused_Variables")
0093 NoUnusedVariables = rsQueryDefs.RecordCount
0094End If
0095 Set rsQueryDefs = CurrentDb.OpenRecordset("Variable_Code_Name_Clashes")
0096If Not rsQueryDefs.EOF Then
0097 DoCmd.OpenQuery ("Variable_Code_Name_Clashes")
0098 NoNameClashes = rsQueryDefs.RecordCount
0099End If
0100 Set rsQueryControl = CurrentDb.OpenRecordset("Deleted_Queries")
0101If Not rsQueryControl.EOF Then
0102 rsQueryControl.MoveLast
0103 DoCmd.OpenQuery ("Deleted_Queries")
0104 NoDeletedQueries = rsQueryControl.RecordCount
0105End If
0106 Set rsTableToRead = CurrentDb.OpenRecordset("Development_Log_List")
0107If Not rsTableToRead.EOF Then
0108 DoCmd.OpenQuery ("Development_Log_List")
0109 NoDevelopmentLogItems = rsTableToRead.RecordCount
0110End If
0111 DoCmd.OpenQuery ("Code_Archive_Xtab_Recent")
0112rsDocumentationControl.Edit
0113rsDocumentationControl.Fields(0).Value = Now()
0114rsDocumentationControl.Fields(1).Value = Duration
0115rsDocumentationControl.Update
0116Set rsQueryControl = Nothing
0117Set rsDocumentationControl = Nothing
0118Set rsTableToRead = Nothing
0119Set rsQueryDefs = Nothing
0120End Sub

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


Source Code of: Monthly_Report_Note980_Update
Procedure Type: Public Sub
Module: Monthly Reporting
Lines of Code: 894
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Monthly_Report_Note980_Update()
0002Dim strLine As String
0003Dim rsTableControl As Recordset
0004Dim rsTableControl2 As Recordset
0005Dim rsTableToRead As Recordset
0006Dim rsPlan As Recordset
0007Dim strQuery As String
0008Dim i As Long
0009Dim j As Integer
0010Dim ifields As Integer
0011Dim Field_Width As Single
0012Dim Field_Width_Temp As Single
0013Dim iTot(25) As Single
0014Dim iTot2(25) As Single
0015Dim iTotal As Single
0016Dim iTotal2 As Single
0017Dim iStart_Month As Integer
0018Dim iFinal_Month As Integer
0019Dim Month_From As String
0020Dim Month_To As String
0021Dim Alignment As String
0022Dim Field_Temp As String
0023Dim Reporting_Years As String
0024Dim Reporting_Quarter As String
0025Dim Total_Weekly_Hours As Single
0026Dim Total_Annual_Hours As Single
0027Dim QTD_Tot As Single
0028Dim iQTD_Days As Integer
0029Dim iYTD_Days As Integer
0030Dim iRemaining_Days As Integer
0031Dim iNext_Qtr_Days As Integer
0032Dim iStart_Next_Qtr As Integer
0033Dim iEnd_Next_Qtr As Integer
0034Dim Month_From_Qry As String
0035Dim Month_To_Qry As String
0036Dim num_Temp As Single
0037Dim QTD_Hours_Left As Single
0038Dim QTD_Days_Left As Single
0039Dim Tot_Plan_YTD As Single
0040Dim iCols As Integer
0041Dim Remaining_Hours_Today As Single
0042Dim Check_Date As Date
0043Dim Check_Month As Integer
0044Dim Check_Year As Integer
0045Dim strPrevious As String
0046Dim QTD_Plan As Single
0047Dim YTD_Plan As Single
0048Dim QTD_Temp As Single
0049'Determine the Parameters
0050 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Next_Reporting_Month.* FROM Next_Reporting_Month;")
0051rsTableControl.MoveFirst
0052iStart_Reporting_Month = rsTableControl.Fields(1)
0053iEnd_Reporting_Month = rsTableControl.Fields(2)
0054iReporting_Year = rsTableControl.Fields(5) ' .... Start Year
0055iStart_Next_Qtr = rsTableControl.Fields(6)
0056iEnd_Next_Qtr = rsTableControl.Fields(7)
0057strFile_Suffix = rsTableControl.Fields(8)
0058If iEnd_Reporting_Month = 12 Then
0059 Check_Month = 1
0060 Check_Year = iReporting_Year + 1
0061 Check_Date = DateValue("01/01" & "/" & Check_Year)
0062Else
0063 Check_Month = iEnd_Reporting_Month + 1
0064 Check_Year = iReporting_Year + IIf(iEnd_Reporting_Month < 10, 1, 0)
0065 Check_Date = DateValue("01/" & Check_Month & "/" & Check_Year)
0066 Check_Date = DateValue("1 " & MonthName(Check_Month) & " " & Check_Year)
0067End If
0068strPrevious = "Previous"
0069If iEnd_Reporting_Month = 12 Then
0070 If Month(Now()) > 9 Then
0071 strPrevious = "Current"
0072 End If
0073Else
0074 If Not Month(Now()) > iEnd_Reporting_Month Then
0075 strPrevious = "Current"
0076 End If
0077End If
0078 strQuery = "SELECT Sum(PlanVsActual.Plan) AS SumOfPlan FROM PlanVsActual WHERE (((PlanVsActual.Date) < Now()) And ((Month([Date])) >= " & iStart_Reporting_Month & " And (Month([Date])) <= " & iEnd_Reporting_Month & ")) HAVING (((Sum(PlanVsActual.Plan))>0));"
0079Set rsPlan = CurrentDb.OpenRecordset(strQuery)
0080rsPlan.MoveFirst
0081QTD_Plan = rsPlan.Fields(0)
0082'strQuery = "SELECT Sum(PlanVsActual.Plan) AS SumOfPlan FROM PlanVsActual WHERE ((PlanVsActual.Date) < Now()) AND (((Year([Date]))<" & Check_Year & ") AND ((PlanVsActual.Plan)>0)) OR (((Year([Date]))=" & Check_Year & ") AND ((Month([Date]))<" & Check_Month & ") AND ((PlanVsActual.Plan)>0));"
0083 strQuery = "SELECT Sum(PlanVsActual.Plan) AS SumOfPlan FROM PlanVsActual WHERE (((PlanVsActual.Date)<Now()) AND ((Year([Date]))<" & Check_Year & ") AND ((PlanVsActual.Plan)>0)) OR (((PlanVsActual.Date)<Now()) AND ((Year([Date]))=" & Check_Year & ") AND ((PlanVsActual.Plan)>0) AND ((Month([Date]))<" & Check_Month & "));"
0084Set rsPlan = CurrentDb.OpenRecordset(strQuery)
0085rsPlan.MoveFirst
0086YTD_Plan = rsPlan.Fields(0)
0087 DoCmd.RunSQL ("DELETE Timesheet_Time_Outstanding.* FROM Timesheet_Time_Outstanding;")
0088 DoCmd.OpenQuery ("Timesheet_Time_Outstanding_GEN")
0089 DoCmd.RunSQL ("DELETE Timesheet_Time_Outstanding.* FROM Timesheet_Time_Outstanding WHERE Timesheet_Time_Outstanding.[Hours] = 0;")
0090 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT Sum(Timesheet_Time_Outstanding.Hours) AS SumOfHours FROM Timesheet_Time_Outstanding, Next_Reporting_Month WHERE (((Timesheet_Time_Outstanding.Month)>=[Start_Reporting_Month] And (Timesheet_Time_Outstanding.Month)<=[Current_Reporting_Month]));")
0091If rsTableToRead.EOF Then
0092 QTD_Hours_Left = 0
0093Else
0094 rsTableToRead.MoveFirst
0095 QTD_Hours_Left = Nz(rsTableToRead.Fields(0).Value)
0096End If
0097If QTD_Hours_Left > 0 Then
0098 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT Timesheet_Time_Outstanding.Hours FROM Timesheet_Time_Outstanding WHERE (((Timesheet_Time_Outstanding.Date)=Date()));")
0099 If rsTableToRead.EOF Then
0100 Remaining_Hours_Today = 0
0101 Else
0102 rsTableToRead.MoveFirst
0103 Remaining_Hours_Today = rsTableToRead.Fields(0).Value
0104 End If
0105Else
0106 Remaining_Hours_Today = 0
0107End If
0108strLine = "This page shows the following tables (which are unlikely to be of any interest to anyone other than myself). Click on the links, or scroll down:-|99|"
0109strLine = strLine & "|1|<A HREF = ""#PlanVersusActual_Split"">Plan versus Actual Effort Summary - Split</A> (" & strPrevious & " Quarter & YTD)"
0110strLine = strLine & "|1|<A HREF = ""#PlanVersusActual_Actual"">Plan versus Actual Effort Summary - Actual</A> (" & strPrevious & " Quarter & YTD)"
0111strLine = strLine & "|1|<A HREF = ""#PlanSummary"">Plan Summary</A> (Next Quarter & Full Year)"
0112strLine = strLine & "|1|<A HREF = ""#ActualPlusPlan"">Actual & Plan Summary</A> (2007 - Current Year)|99|"
0113'Add links to other reports ...
0114strLine = strLine & "For convenience, here are links to the other reports in this set. Clicking on the link takes you from this page to the relevant report:- "
0115strLine = strLine & "|99|"
0116strLine = strLine & "|1|[Click Here]++1005++ for Actual Detail Summary (2007 - " & iReporting_Year & ") by Sub-Project"
0117strLine = strLine & "|1|[Click Here]++863++ for (by Project)|..||.|Summary of Effort YTD & QTD|.|Time Analysis (YTD by Study-location)|..|"
0118strLine = strLine & "|99|<hr>"
0119'Add hours per weekday tables
0120strLine = strLine & "Firstly, a couple of tables showing how my time expenditure by weekday compares to that planned:- <br><br><center><TABLE class = ""Bridge"" WIDTH=1100><TR>"
0121strLine = strLine & "<TD><center>Table of actual hours versus hours planned, by weekday, YTD<!-- FUNCTOR_ID=21, 39 --> <!-- FUNCTOR_END ID=21 --></center></TD>"
0122strLine = strLine & "<TD><center>Table of actual hours versus hours planned, by weekday, for the current Quarter<!-- FUNCTOR_ID=21, 40 --> <!-- FUNCTOR_END ID=21 --></center></td></TR></TABLE></center><br><hr>"
0123'
0124Month_From = iReporting_Year & "_10"
0125Month_From_Qry = iReporting_Year & "-10"
0126Month_To = iReporting_Year + 1 & "_09"
0127Month_To_Qry = iReporting_Year + 1 & "-09"
0128Reporting_Years = iReporting_Year & "/" & Right(iReporting_Year + 1, 2)
0129Reporting_Quarter = MonthName(iStart_Reporting_Month)
0130If iEnd_Reporting_Month < iStart_Reporting_Month Then
0131 Reporting_Quarter = Reporting_Quarter & " " & iReporting_Year & " - " & MonthName(iEnd_Reporting_Month) & " " & iReporting_Year + 1
0132Else
0133 Reporting_Quarter = Reporting_Quarter & " - " & MonthName(iEnd_Reporting_Month)
0134 If iStart_Reporting_Month > 9 Then
0135 Reporting_Quarter = Reporting_Quarter & " " & iReporting_Year
0136 Else
0137 Reporting_Quarter = Reporting_Quarter & " " & iReporting_Year + 1
0138 End If
0139End If
0140If iEnd_Reporting_Month = 12 Then
0141 i = DateValue("01/01/" & iReporting_Year + 1)
0142Else
0143 i = DateValue("01/" & iEnd_Reporting_Month + 1 & "/" & iReporting_Year + IIf(iEnd_Reporting_Month < 10, 1, 0))
0144End If
0145iQTD_Days = i - DateValue("01/" & iStart_Reporting_Month & "/" & iReporting_Year + IIf(iStart_Reporting_Month < 10, 1, 0))
0146iYTD_Days = i - DateValue("01/10/" & iReporting_Year)
0147strLine = strLine & "<a name = ""PlanVersusActual_Split""></A><h3>Plan versus Actual Effort Summary - Split (" & strPrevious & " Quarter & YTD)</h3><BR>Summary figures against the QTD (" & Reporting_Quarter & ") Plan, and for the YTD (" & Reporting_Years & ") Academic Year, are as below. This table shows the <b><u>actual %age split</u></b> of work (YTD & QTD) as against the planned %age split of work. The second table below compares the <strong><U>amount</strong></U> of work done, as against plan:-<BR><BR><CENTER>"
0148Month_From = IIf(iStart_Reporting_Month < 10, iReporting_Year + 1, iReporting_Year) & "_" & Right(100 + iStart_Reporting_Month, 2)
0149Month_To = IIf(iEnd_Reporting_Month < 10, iReporting_Year + 1, iReporting_Year) & "_" & Right(100 + iEnd_Reporting_Month, 2)
0150If iEnd_Reporting_Month > 9 Then
0151 iFinal_Month = iEnd_Reporting_Month - 3
0152Else
0153 iFinal_Month = iEnd_Reporting_Month + 9 'Was 6
0154End If
0155If iStart_Reporting_Month > 9 Then
0156 iStart_Month = iStart_Reporting_Month - 3
0157Else
0158 iStart_Month = iStart_Reporting_Month + 9
0159End If
0160 strQuery = "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) >= """ & Month_From_Qry & """ And (Year_Crosstab.Period) <= """ & Month_To_Qry & """) 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;"
0161Set rsTableControl2 = CurrentDb.OpenRecordset(strQuery)
0162rsTableControl2.MoveFirst
0163ifields = rsTableControl2.Fields.Count
0164Field_Width = 100 / (ifields - 12)
0165If Not rsTableControl2.EOF Then
0166 rsTableControl2.MoveFirst
0167 strLine = strLine & "<TABLE class = ""Bridge"" WIDTH=1300>"
0168End If
0169strLine = strLine & "<TR>"
0170j = 0
0171Do While j < ifields - 12
0172 If j = 0 Then
0173 Field_Width_Temp = Field_Width
0174 Alignment = "Left"
0175 Field_Temp = rsTableControl2.Fields(j)
0176 Else
0177 Field_Width_Temp = Field_Width
0178 Alignment = "Center"
0179 Field_Temp = Nz(Round(rsTableControl2.Fields(j), 0))
0180 End If
0181 strLine = strLine & "<TH WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & rsTableControl2.Fields(j).Name & "</TH>"
0182 j = j + 1
0183Loop
0184strLine = strLine & "</TR>"
0185Total_Weekly_Hours = 0
0186Total_Annual_Hours = 0
0187iTotal = 0
0188iTotal2 = 0
0189j = 8
0190rsTableControl2.MoveFirst
0191'Find the totals
0192Do While Not rsTableControl2.EOF
0193 Total_Weekly_Hours = Total_Weekly_Hours + rsTableControl2.Fields(1)
0194 Total_Annual_Hours = Total_Annual_Hours + rsTableControl2.Fields(4)
0195 Do While j < ifields
0196 If j < iFinal_Month + 2 And j > 7 Then
0197 iTotal = iTotal + Nz(rsTableControl2.Fields(j)) 'YTD
0198 End If
0199 If j < iFinal_Month + 2 And j > iStart_Month Then
0200 iTotal2 = iTotal2 + Nz(rsTableControl2.Fields(j)) 'QTD
0201 End If
0202 j = j + 1
0203 Loop
0204 j = 8
0205 rsTableControl2.MoveNext
0206Loop
0207'Output the rows
0208For j = 0 To 20
0209 iTot(j) = 0
0210Next j
0211rsTableControl2.MoveFirst
0212Do While Not rsTableControl2.EOF
0213 strLine = strLine & "<TR>"
0214 j = 8
0215 YTD_Tot = 0
0216 QTD_Tot = 0
0217 Do While j < ifields
0218 If j < iFinal_Month + 2 Then
0219 YTD_Tot = YTD_Tot + Nz(rsTableControl2.Fields(j))
0220 iTot(7) = iTot(7) + Nz(rsTableControl2.Fields(j)) 'YTD
0221 End If
0222 If j < iFinal_Month + 2 And j > iStart_Month Then
0223 QTD_Tot = QTD_Tot + Nz(rsTableControl2.Fields(j))
0224 iTot(6) = iTot(6) + Nz(rsTableControl2.Fields(j)) 'QTD
0225 End If
0226 j = j + 1
0227 Loop
0228 j = 0
0229 Do While j < 8
0230 Select Case j
0231 Case 0, 1
0232 Field_Temp = rsTableControl2.Fields(j)
0233 Case 2
0234 Field_Temp = rsTableControl2.Fields(1) / Total_Weekly_Hours * 100
0235 Case 3
0236 Field_Temp = QTD_Tot / iTotal2 * 100
0237 Case 4
0238 Field_Temp = rsTableControl2.Fields(4) / (Total_Annual_Hours + 0.00001) * 100
0239 Case 5
0240 Field_Temp = YTD_Tot / iTotal * 100
0241 Case 6
0242 Field_Temp = QTD_Tot
0243 Case 7
0244 Field_Temp = YTD_Tot
0245 End Select
0246 If j > 0 Then
0247 If Field_Temp <= 0.5 Then
0248 Field_Temp = "&nbsp;"
0249 Else
0250 Field_Temp = Round(Field_Temp, 0)
0251 End If
0252 End If
0253 If j = 0 Then
0254 Field_Width_Temp = Field_Width
0255 Alignment = "Left"
0256 Else
0257 Field_Width_Temp = Field_Width
0258 Alignment = "Center"
0259 End If
0260 strLine = strLine & "<TD WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & Field_Temp & "</TD>"
0261 j = j + 1
0262 Loop
0263 strLine = strLine & "</TR>"
0264 rsTableControl2.MoveNext
0265Loop
0266'Gap Row
0267strLine = strLine & "<TR>"
0268j = 0
0269Field_Temp = "&nbsp;"
0270Do While j < 8
0271 Field_Width_Temp = Field_Width
0272 strLine = strLine & "<TD WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & Field_Temp & "</TD>"
0273 j = j + 1
0274Loop
0275strLine = strLine & "</TR>"
0276'Total Row
0277strLine = strLine & "<TR>"
0278j = 0
0279Do While j < 8
0280 If j = 0 Then
0281 Field_Width_Temp = Field_Width
0282 Alignment = "Left"
0283 Else
0284 Field_Width_Temp = Field_Width
0285 Alignment = "Center"
0286 Field_Temp = Round(iTot(j), 0)
0287 End If
0288 Select Case j
0289 Case 0
0290 Field_Temp = "TOTALS"
0291 Case 1
0292 Field_Temp = Total_Weekly_Hours
0293 Case 2, 3, 4, 5
0294 Field_Temp = 100
0295 Case 6
0296 Field_Temp = Round(iTotal2, 0)
0297 Case 7
0298 Field_Temp = Round(iTotal, 0)
0299 YTD_Tot_Saved = iTotal 'Save for later spreadsheet!
0300 End Select
0301 Field_Temp = "<strong>" & Field_Temp & "</strong>"
0302 strLine = strLine & "<TD bgcolor=yellow WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & Field_Temp & "</TD>"
0303 j = j + 1
0304Loop
0305strLine = strLine & "</TR>"
0306'Gap Row
0307strLine = strLine & "<TR>"
0308j = 0
0309Field_Temp = "&nbsp;"
0310Do While j < 8
0311 Field_Width_Temp = Field_Width
0312 strLine = strLine & "<TD WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & Field_Temp & "</TD>"
0313 j = j + 1
0314Loop
0315strLine = strLine & "</TR>"
0316'Final Row
0317If Check_Date > Date Then
0318 QTD_Days_Left = Check_Date - Date - 1
0319 'Excludes today
0320 rsTableControl.Edit
0321 rsTableControl.Fields(11) = iQTD_Days 'Total Days in Current Qtr
0322 iQTD_Days = iQTD_Days - QTD_Days_Left
0323 iYTD_Days = iYTD_Days - QTD_Days_Left
0324 rsTableControl.Fields(10) = iQTD_Days 'Qtr Days Gone
0325 rsTableControl.Fields(12) = Remaining_Hours_Today
0326 rsTableControl.Update
0327Else
0328 QTD_Days_Left = 0
0329End If
0330j = 0
0331Do While j < 8
0332 If j = 0 Then
0333 Field_Width_Temp = Field_Width
0334 Alignment = "Left"
0335 Else
0336 Field_Width_Temp = Field_Width
0337 Alignment = "Center"
0338 Field_Temp = Round(iTot(j), 0)
0339 End If
0340 Select Case j
0341 Case 0
0342 Field_Temp = "Comparisons"
0343 Case 1
0344 Field_Temp = iQTD_Days & " days"
0345 Case 2
0346 Field_Temp = iYTD_Days & " days"
0347 Case 3
0348 Field_Temp = Round(iTotal2 / (QTD_Plan - Remaining_Hours_Today) * 100, 0) & "%"
0349 Case 4
0350 Field_Temp = "&nbsp;"
0351 Case 5
0352 Field_Temp = Round(iTotal / (YTD_Plan - Remaining_Hours_Today) * 100, 0) & "%"
0353 Case 6
0354 Field_Temp = Round(QTD_Plan - Remaining_Hours_Today, 0)
0355 Case 7
0356 Field_Temp = Round(YTD_Plan - Remaining_Hours_Today, 0)
0357 End Select
0358 Field_Temp = "<strong>" & Field_Temp & "</strong>"
0359 strLine = strLine & "<TD WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & Field_Temp & "</TD>"
0360 j = j + 1
0361Loop
0362strLine = strLine & "</TR>"
0363'Footer
0364 strLine = strLine & "</TABLE></CENTER><br><b><u>Notes</u></b>|..||.|All figures above are rounded to the nearest unit. |.|The bottom row - ""Comparisons"" - in the above table is non-standard. <br>&rarr; The first two columns show the number of days in the current reporting Quarter and YTD, and <br>&rarr; the last two columns show the hours planned (according to the latest quarterly plan) for the current reporting Quarter and pro-rata YTD. <br>&rarr; The middle non-empty columns show %age actual vs plan (actuals taken from the Total row) for the Quarter and YTD. |.|In principle this allows monitoring of total effort vs plan, as well as the distribution of effort across projects. |..|<br>"
0365'Second Table
0366strLine = strLine & "<hr><a name = ""PlanVersusActual_Actual""></A><h3>Plan versus Actual Effort Summary - Effort (" & strPrevious & " Quarter & YTD)</h3><BR>Summary figures against the QTD (" & Reporting_Quarter & ") Plan, and for the YTD (" & Reporting_Years & ") Academic Year, are as below. This table shows the <strong><U>actual</strong></U> percentage against plan:-<BR><BR><CENTER>"
0367 strQuery = "TRANSFORM Sum([Year_Crosstab].[Hours ]) AS Hours SELECT Average_Plans.Project, Average_Plans.[Average This Qtr Plan] AS [Planned Weekly Hours], Round(Average_Plans.[Average YTD Plan],4) AS [Planned %age], Sum(0) AS [QTD Actual %], 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) >= """ & Month_From_Qry & """ And (Year_Crosstab.Period) <= """ & Month_To_Qry & """) Or (Year_Crosstab.Period) Is Null)) GROUP BY Average_Plans.Project, Average_Plans.[Average This Qtr Plan], Round([Average YTD Plan],4) ORDER BY Average_Plans.Project PIVOT Year_Crosstab.Period;"
0368Set rsTableControl2 = CurrentDb.OpenRecordset(strQuery)
0369rsTableControl2.MoveFirst
0370ifields = rsTableControl2.Fields.Count
0371Field_Width = 100 / (ifields - 12)
0372If Not rsTableControl2.EOF Then
0373 rsTableControl2.MoveFirst
0374 strLine = strLine & "<TABLE class = ""Bridge"" WIDTH=1100>"
0375End If
0376strLine = strLine & "<TR>"
0377'Output headings
0378j = 0
0379Do While j < ifields - 12
0380 Field_Width_Temp = Field_Width
0381 Field_Temp = rsTableControl2.Fields(j).Name
0382 Alignment = "Center"
0383 Select Case j
0384 Case 0
0385 Alignment = "Left"
0386 Case 1
0387 Field_Temp = "QTD Planned Hours"
0388 Case 2
0389 Field_Temp = "YTD Planned Hours"
0390 Case 3
0391 Field_Temp = rsTableControl2.Fields(5).Name
0392 Case 4
0393 Field_Temp = rsTableControl2.Fields(6).Name
0394 Case 5
0395 Field_Temp = "QTD Actual % v Plan"
0396 Case 6
0397 Field_Temp = "YTD Actual % v Plan"
0398 End Select
0399 strLine = strLine & "<TH WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & Field_Temp & "</TH>"
0400 j = j + 1
0401Loop
0402strLine = strLine & "</TR>"
0403Tot_Plan_YTD = 0
0404rsTableControl2.MoveFirst
0405'Pre-run to calculate YTD totals for subsequent rebasing
0406Do While Not rsTableControl2.EOF
0407 If iStart_Reporting_Month = 10 Then
0408 Field_Temp = rsTableControl2.Fields(1) * (YTD_Plan - Remaining_Hours_Today) / Total_Weekly_Hours
0409 Else
0410 Field_Temp = rsTableControl2.Fields(2) * (iYTD_Days - Remaining_Hours_Today / 7) / 7
0411 End If
0412 Tot_Plan_YTD = Tot_Plan_YTD + Field_Temp
0413 rsTableControl2.MoveNext
0414Loop
0415rsTableControl2.MoveFirst
0416'Output the table!
0417Do While Not rsTableControl2.EOF
0418 strLine = strLine & "<TR>"
0419 j = 7
0420 YTD_Tot = 0
0421 QTD_Tot = 0
0422 Do While j < iFinal_Month + 1
0423 If j < iFinal_Month + 1 Then
0424 YTD_Tot = YTD_Tot + Nz(rsTableControl2.Fields(j))
0425 End If
0426 If j < iFinal_Month + 1 And j > iStart_Month - 1 Then
0427 QTD_Tot = QTD_Tot + Nz(rsTableControl2.Fields(j))
0428 End If
0429 j = j + 1
0430 Loop
0431 j = 0
0432 Do While j < 7
0433 Select Case j
0434 Case 0
0435 Field_Temp = rsTableControl2.Fields(j)
0436 Case 1
0437 Field_Temp = rsTableControl2.Fields(1) * (QTD_Plan - Remaining_Hours_Today) / Total_Weekly_Hours
0438 QTD_Temp = Field_Temp
0439 Case 2
0440 'This is slightly inaccurate if this Quarter has a holiday in it ... can't be bothered to fix, except if this is Q1 when force to QTD
0441 If iStart_Reporting_Month = 10 Then
0442 Field_Temp = QTD_Temp
0443 Else
0444 Field_Temp = (rsTableControl2.Fields(2) * (iYTD_Days - Remaining_Hours_Today / 7) / 7) * YTD_Plan / Tot_Plan_YTD
0445 End If
0446 Case 3
0447 Field_Temp = Round(QTD_Tot, 0)
0448 Case 4
0449 Field_Temp = Round(YTD_Tot, 0)
0450 Case 5
0451 num_Temp = Trim(rsTableControl2.Fields(1))
0452 If num_Temp = 0 Then
0453 Field_Temp = 0
0454 Else
0455 Field_Temp = QTD_Tot / (rsTableControl2.Fields(1) * iQTD_Days / 7 - Remaining_Hours_Today * rsTableControl2.Fields(1) / Total_Weekly_Hours) * 100
0456 End If
0457 QTD_Temp = Field_Temp
0458 Case 6
0459 num_Temp = Trim(rsTableControl2.Fields(2))
0460 If num_Temp = 0 Then
0461 Field_Temp = 0
0462 Else
0463 'This didn't agree for Q1, when it should ... though the methodologies are different, so I've forced equality!
0464 If iStart_Reporting_Month = 10 Then
0465 Field_Temp = QTD_Temp
0466 Else
0467 Field_Temp = YTD_Tot / (rsTableControl2.Fields(2) * (iYTD_Days - Remaining_Hours_Today / 7) / 7) * 100 / YTD_Plan * Tot_Plan_YTD
0468 End If
0469 End If
0470 End Select
0471 If j > 0 Then
0472 If Field_Temp < 0.05 Then
0473 Field_Temp = "&nbsp;"
0474 Else
0475 If Field_Temp < 1 Then
0476 Field_Temp = Round(Field_Temp, 1)
0477 Else
0478 Field_Temp = Round(Field_Temp, 0)
0479 End If
0480 End If
0481 End If
0482 Field_Width_Temp = Field_Width
0483 If j = 0 Then
0484 Alignment = "Left"
0485 Else
0486 Alignment = "Center"
0487 End If
0488 strLine = strLine & "<TD WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & Field_Temp & "</TD>"
0489 j = j + 1
0490 Loop
0491 strLine = strLine & "</TR>"
0492 rsTableControl2.MoveNext
0493Loop
0494Tot_Plan_YTD = YTD_Plan - Remaining_Hours_Today
0495strLine = strLine & "<TR>"
0496'Gap Row
0497strLine = strLine & "<TR>"
0498j = 0
0499Field_Temp = "&nbsp;"
0500Do While j < 7
0501 Field_Width_Temp = Field_Width
0502 strLine = strLine & "<TD WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & Field_Temp & "</TD>"
0503 j = j + 1
0504Loop
0505strLine = strLine & "</TR>"
0506'Total Row
0507j = 0
0508Do While j < 7
0509 If j = 0 Then
0510 Field_Width_Temp = Field_Width
0511 Alignment = "Left"
0512 Else
0513 Field_Width_Temp = Field_Width
0514 Alignment = "Center"
0515 Field_Temp = Round(iTot(j), 0)
0516 End If
0517 Select Case j
0518 Case 0
0519 Field_Temp = "TOTALS"
0520 Case 1
0521 Field_Temp = Round(QTD_Plan - Remaining_Hours_Today, 0)
0522 Case 2
0523 Field_Temp = Round(Tot_Plan_YTD, 0)
0524 Case 3
0525 Field_Temp = Round(iTotal2, 0)
0526 Case 4
0527 Field_Temp = Round(iTotal, 0)
0528 Case 5
0529 Field_Temp = Round(iTotal2 / (QTD_Plan - Remaining_Hours_Today) * 100, 0) & "%"
0530 Case 6
0531 Field_Temp = Round(iTotal / Tot_Plan_YTD * 100, 0) & "%"
0532 End Select
0533 Field_Temp = "<strong>" & Field_Temp & "</strong>"
0534 strLine = strLine & "<TD bgcolor=yellow WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & Field_Temp & "</TD>"
0535 j = j + 1
0536Loop
0537strLine = strLine & "</TR>"
0538'Footer
0539strLine = strLine & "</TABLE></CENTER><BR><u><b>Notes</b></u>|..||.|All figures above are rounded to the nearest unit. |..|"
0540'Third Table
0541 strLine = strLine & "<BR><hr><BR><a name = ""PlanSummary""></A><h3>Plan Summary (Next Quarter & Full Year)</h3><BR>The plan for the distribution of effort, in hours / week, for the coming Quarter & Academic Year is as below. As the year goes by, estimates are replaced by actuals, and re-estimates are made. In the final quarter of the academic year (July - September) this table just shows the plan for the next academic year. In the light of the above ""re-focusing"" decisions, Secondary Projects have no time estimated for them:-<BR><BR><CENTER>"
0542'Find Days in next Qtr
0543If iEnd_Next_Qtr = 12 Then
0544 i = DateValue("01/01/" & iReporting_Year + 1)
0545Else
0546 i = DateValue("01/" & iEnd_Next_Qtr + 1 & "/" & iReporting_Year + IIf(iEnd_Next_Qtr < 10, 1, 0))
0547End If
0548iNext_Qtr_Days = i - DateValue("01/" & iStart_Next_Qtr & "/" & iReporting_Year + IIf(iStart_Next_Qtr < 10, 1, 0))
0549iRemaining_Days = DateValue("01/10/" & iReporting_Year + 1) - DateValue("01/" & iStart_Next_Qtr & "/" & iReporting_Year + IIf(iStart_Next_Qtr < 10, 1, 0))
0550If iRemaining_Days > 360 Then
0551 iRemaining_Days = 0
0552End If
0553 Set rsTableControl2 = CurrentDb.OpenRecordset("qryActualvsPlan")
0554rsTableControl2.MoveFirst
0555iCols = 8
0556If iStart_Next_Qtr = 10 Then
0557 iCols = iCols - 1
0558End If
0559Field_Width = 100 / iCols
0560If Not rsTableControl2.EOF Then
0561 rsTableControl2.MoveFirst
0562 strLine = strLine & "<TABLE class = ""Bridge"" WIDTH=950>"
0563End If
0564strLine = strLine & "<TR>"
0565'Header Rows
0566j = 0
0567Do While j < 8
0568 Field_Width_Temp = Field_Width
0569 Alignment = "Center"
0570 Select Case j
0571 Case 0
0572 Alignment = "Left"
0573 Field_Temp = rsTableControl2.Fields(j).Name
0574 Case 1
0575 Field_Temp = "Planned Hours / Week Next Qtr"
0576 Case 2
0577 Field_Temp = "Planned %age Next Qtr"
0578 Case 3
0579 Field_Temp = "Full Year Planned %age"
0580 Case 4
0581 Field_Temp = "Planned Hours Next Qtr"
0582 Case 5
0583 Field_Temp = "Full Year Planned Hours"
0584 Case 6
0585 Field_Temp = "Full Year Actual + Planned Hours"
0586 Case 7
0587 Field_Temp = "Comparison (%ages)"
0588 End Select
0589 strLine = strLine & IIf(iStart_Next_Qtr = 10 And j = 6, "", "<TH WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & Field_Temp & "</TH>")
0590 j = j + 1
0591Loop
0592strLine = strLine & "</TR>"
0593Total_Weekly_Hours = 0
0594iTotal = 0
0595iTotal2 = 0
0596QTD_Tot = 0
0597rsTableControl2.MoveFirst
0598'Find the totals
0599Do While Not rsTableControl2.EOF
0600 Total_Weekly_Hours = Total_Weekly_Hours + rsTableControl2.Fields(1)
0601 iTotal = iTotal + rsTableControl2.Fields(2) 'Full Year Plan
0602 rsTableControl2.MoveNext
0603Loop
0604'Output the rows
0605For j = 0 To 20
0606 iTot(j) = 0
0607Next j
0608rsTableControl2.MoveFirst
0609Do While Not rsTableControl2.EOF
0610 strLine = strLine & "<TR>"
0611 j = 0
0612 Do While j < 8
0613 Field_Width_Temp = Field_Width
0614 Alignment = "Center"
0615 Select Case j
0616 Case 0
0617 Alignment = "Left"
0618 Field_Temp = rsTableControl2.Fields(j)
0619 Case 1
0620 Field_Temp = rsTableControl2.Fields(j)
0621 Case 2
0622 Field_Temp = rsTableControl2.Fields(1) / Total_Weekly_Hours * 100
0623 Case 3
0624 Field_Temp = rsTableControl2.Fields(2) / iTotal * 100
0625 Case 4
0626 Field_Temp = rsTableControl2.Fields(1) * iNext_Qtr_Days / 7
0627 Case 5
0628 Field_Temp = rsTableControl2.Fields(2) * 365 / 7
0629 Case 6
0630 If iStart_Next_Qtr = 10 Then
0631 'No actuals yet - this is next year's plan
0632 Else
0633 Field_Temp = IIf(rsTableControl2.Fields(4) & "" = "", 0, rsTableControl2.Fields(4)) + Nz(rsTableControl2.Fields(3)) * iRemaining_Days / 7 + rsTableControl2.Fields(1) * QTD_Days_Left / 7
0634 End If
0635 Case 7
0636 If rsTableControl2.Fields(2) = 0 Then
0637 Field_Temp = 0
0638 Else
0639 If iStart_Next_Qtr = 10 Then
0640 Field_Temp = 100
0641 Else
0642 Field_Temp = (IIf(rsTableControl2.Fields(4) & "" = "", 0, rsTableControl2.Fields(4)) + Nz(rsTableControl2.Fields(3)) * iRemaining_Days / 7 + rsTableControl2.Fields(1) * QTD_Days_Left / 7) / (rsTableControl2.Fields(2) * 365 / 7) * 100
0643 End If
0644 End If
0645 End Select
0646 If j > 0 Then
0647 iTot(j) = iTot(j) + Val(Field_Temp)
0648 If Val(Field_Temp) < 0.05 Then
0649 Field_Temp = "&nbsp;"
0650 Else
0651 If Field_Temp < 0.05 Then
0652 Field_Temp = Round(Field_Temp, 1)
0653 Else
0654 Field_Temp = Round(Field_Temp, 0)
0655 End If
0656 End If
0657 End If
0658 strLine = strLine & IIf(iStart_Next_Qtr = 10 And j = 6, "", "<TD WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & Field_Temp & "</TD>")
0659 j = j + 1
0660 Loop
0661 strLine = strLine & "</TR>"
0662 rsTableControl2.MoveNext
0663Loop
0664'Gap Row
0665strLine = strLine & "<TR>"
0666j = 0
0667Field_Temp = "&nbsp;"
0668Do While j < IIf(iStart_Next_Qtr = 10, 7, 8)
0669 Field_Width_Temp = Field_Width
0670 strLine = strLine & "<TD WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & Field_Temp & "</TD>"
0671 j = j + 1
0672Loop
0673strLine = strLine & "</TR>"
0674strLine = strLine & "<TR>"
0675'Total Row
0676j = 0
0677Do While j < 8
0678 Field_Width_Temp = Field_Width
0679 Alignment = "Center"
0680 Select Case j
0681 Case 0
0682 Alignment = "Left"
0683 Field_Temp = "TOTALS"
0684 Case 1, 2, 3, 4, 5, 6
0685 Field_Temp = Round(iTot(j), 0)
0686 Case 7
0687 Field_Temp = Round(iTot(6) / iTot(5) * 100, 0)
0688 End Select
0689 Field_Temp = "<strong>" & Field_Temp & "</strong>"
0690 strLine = strLine & IIf(iStart_Next_Qtr = 10 And j = 6, "", "<TD bgcolor=yellow WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & Field_Temp & "</TD>")
0691 j = j + 1
0692Loop
0693strLine = strLine & "</TR>"
0694'Footer
0695strLine = strLine & "</TABLE></CENTER><BR><BR>All figures above are rounded to the nearest unit. <br><br>"
0696'Fourth (final) Table
0697 strLine = strLine & "<hr><BR><a name = ""ActualPlusPlan""></A><h3>Actual & Plan Summary (2007 - " & iReporting_Year + 1 & ")</h3><BR>Below is a table showing the split amongst my various projects of time expended or planned over a " & iReporting_Year - 2007 + 1 & "-year period. :-<BR><BR><CENTER>"
0698 Set rsTableControl2 = CurrentDb.OpenRecordset("qryPastActuals")
0699rsTableControl2.MoveFirst
0700ifields = rsTableControl2.Fields.Count
0701Field_Width = 100 / (ifields + 2)
0702If Not rsTableControl2.EOF Then
0703 rsTableControl2.MoveFirst
0704 strLine = strLine & "<TABLE class = ""Bridge"" WIDTH=950>"
0705End If
0706strLine = strLine & "<TR>"
0707'Header Rows
0708j = 0
0709Do While j < ifields
0710 Field_Width_Temp = Field_Width
0711 Alignment = "Center"
0712 Select Case j
0713 Case 0
0714 Field_Width_Temp = Field_Width * 2
0715 Alignment = "Left"
0716 Field_Temp = rsTableControl2.Fields(j).Name
0717 Case 1, 2
0718 Field_Temp = "Not Required"
0719 Case Is > 2
0720 Field_Temp = rsTableControl2.Fields(j).Name & " (Actuals)"
0721 End Select
0722 If Field_Temp <> "Not Required" Then
0723 strLine = strLine & "<TH WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & Field_Temp & "</TH>"
0724 End If
0725 j = j + 1
0726Loop
0727For j = 1 To 3
0728 Select Case j
0729 Case 1
0730 Field_Temp = iReporting_Year & "/" & Right(iReporting_Year + 1, 2) & " (Actual + Plan)"
0731 Case 2
0732 Field_Temp = "Total"
0733 Case 3
0734 Field_Temp = "%age"
0735 End Select
0736 strLine = strLine & "<TH WIDTH=""" & Round(Field_Width_Temp, 1) & "%""><strong>" & Field_Temp & "</strong></TH>"
0737Next j
0738strLine = strLine & "</TR>"
0739'Output the rows
0740For j = 0 To 20
0741 iTot(j) = 0
0742Next j
0743For i = 0 To 20
0744 iTot2(i) = 0
0745Next i
0746i = 0
0747rsTableControl2.MoveFirst
0748Do While Not rsTableControl2.EOF
0749 i = i + 1
0750 strLine = strLine & "<TR>"
0751 j = 0
0752 iTotal = 0
0753 Do While j < ifields
0754 Field_Width_Temp = Field_Width
0755 Alignment = "Center"
0756 Select Case j
0757 Case 0
0758 Field_Width_Temp = Field_Width * 2
0759 Alignment = "Left"
0760 Field_Temp = rsTableControl2.Fields(j)
0761 Case 1, 2
0762 Field_Temp = "Not Required"
0763 Case Is > 2
0764 Field_Temp = IIf(rsTableControl2.Fields(j) & "" = "", 0, rsTableControl2.Fields(j))
0765 iTot(j) = iTot(j) + Field_Temp
0766 iTotal = iTotal + Field_Temp
0767 End Select
0768 If j > 2 Then
0769 If Field_Temp < 0.05 Then
0770 Field_Temp = "&nbsp;"
0771 Else
0772 If Field_Temp < 0.05 Then
0773 Field_Temp = Round(Field_Temp, 1)
0774 Else
0775 Field_Temp = Round(Field_Temp, 0)
0776 End If
0777 End If
0778 End If
0779 If Field_Temp <> "Not Required" Then
0780 strLine = strLine & "<TD WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & Field_Temp & "</TD>"
0781 End If
0782 j = j + 1
0783 Loop
0784 For j = 1 To 3
0785 Select Case j
0786 Case 1
0787 Field_Temp = rsTableControl2.Fields(1) + Nz(rsTableControl2.Fields(2)) * (iRemaining_Days + QTD_Days_Left) / 7
0788 iTot(ifields) = iTot(ifields) + Field_Temp
0789 iTotal = iTotal + Field_Temp
0790 Case 2
0791 Field_Temp = iTotal
0792 iTot(ifields + 1) = iTot(ifields + 1) + Field_Temp
0793 Case 3
0794 iTot2(i) = Field_Temp
0795 Field_Temp = "++" & i & "++"
0796 End Select
0797 If InStr(Field_Temp, "++") = 0 Then
0798 If Field_Temp < 0.05 Then
0799 Field_Temp = "&nbsp;"
0800 Else
0801 If Field_Temp < 0.05 Then
0802 Field_Temp = Round(Field_Temp, 1)
0803 Else
0804 Field_Temp = Round(Field_Temp, 0)
0805 End If
0806 End If
0807 End If
0808 strLine = strLine & "<TD WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & Field_Temp & "</TD>"
0809 Next j
0810 strLine = strLine & "</TR>"
0811 rsTableControl2.MoveNext
0812Loop
0813'Gap Row
0814strLine = strLine & "<TR>"
0815j = 0
0816Field_Temp = "&nbsp;"
0817Do While j < ifields + 1
0818 Field_Width_Temp = Field_Width
0819 strLine = strLine & "<TD WIDTH=""" & Round(Field_Width_Temp, 1) & "%"">" & Field_Temp & "</TD>"
0820 j = j + 1
0821Loop
0822strLine = strLine & "</TR>"
0823'Total Row
0824j = 0
0825iTotal = 0
0826strLine = strLine & "<TR>"
0827Do While j < ifields + 3
0828 Field_Width_Temp = Field_Width
0829 Alignment = "Center"
0830 Select Case j
0831 Case 0
0832 Field_Width_Temp = Field_Width * 2
0833 Alignment = "Left"
0834 Field_Temp = "TOTALS"
0835 Case 1, 2
0836 Field_Temp = "Not Required"
0837 Case ifields + 1
0838 Field_Temp = iTotal
0839 Case ifields + 2
0840 Field_Temp = 100
0841 Case Else
0842 Field_Temp = iTot(j)
0843 iTotal = iTotal + iTot(j)
0844 End Select
0845 If j > 2 Then
0846 If Field_Temp < 0.05 Then
0847 Field_Temp = "&nbsp;"
0848 Else
0849 If Field_Temp < 0.05 Then
0850 Field_Temp = Round(Field_Temp, 1)
0851 Else
0852 Field_Temp = Round(Field_Temp, 0)
0853 End If
0854 End If
0855 End If
0856 If Field_Temp <> "Not Required" Then
0857 strLine = strLine & "<TD bgcolor=yellow WIDTH=""" & Round(Field_Width_Temp, 1) & "%""><strong>" & Field_Temp & "</strong></TD>"
0858 End If
0859 j = j + 1
0860Loop
0861'Save Historic Total for later
0862Historic_Total = iTot(ifields + 1) - iTot(ifields) + YTD_Tot_Saved
0863For j = 1 To i
0864 strLine = Replace(strLine, "++" & j & "++", Round(iTot2(j) / iTotal * 100, 2))
0865Next j
0866strLine = strLine & "</TR>"
0867'Footer
0868strLine = strLine & "</TABLE></CENTER>"
0869'Read Note 980 for update
0870 strQuery = "SELECT Notes.* FROM Notes WHERE Notes.ID = 980;"
0871Set rsTableControl = CurrentDb.OpenRecordset(strQuery)
0872rsTableControl.MoveFirst
0873rsTableControl.Edit
0874'Update Note 980
0875rsTableControl.Fields(3) = strLine
0876'Note Title
0877strLine = "Status: Summary - Actual versus Plan (" & StrTitle_Year & " - " & StrTitle_Month & ")"
0878rsTableControl.Fields(1) = strLine
0879'Set Note Status
0880rsTableControl.Fields(10) = "Temp"
0881rsTableControl.Update
0882'Output the note
0883 DoCmd.RunSQL ("DELETE Notes_To_Regen.* FROM Notes_To_Regen;")
0884 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Notes_To_Regen.* FROM Notes_To_Regen;")
0885rsTableControl.AddNew
0886rsTableControl.Fields(0) = 980
0887rsTableControl.Update
0888Archive_Notes_Now = "No"
0889Regenerate_the_Links = "No"
0890Regen_Notes_Only = "Yes"
0891 CreateNotesWebPages
0892Set rsTableControl = Nothing
0893Set rsTableControl2 = Nothing
0894End Sub

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


Source Code of: Sub_Function_Call_Checker
Procedure Type: Public Function
Module: Documentation
Lines of Code: 89
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Sub_Function_Call_Checker(Sub_Function, Code)
0002Dim Code_Local As String
0003Dim strRoutine As String
0004Dim strTest As String
0005Dim strCheck As String
0006Dim i As Long
0007Dim j As Long
0008Dim k As Long
0009Dim iTest As Long
0010Dim iTestSaved As String
0011Dim rsTableToUpdate As Recordset
0012 Dim Code_Location As String
0013Code_Local = Code
0014rsCodeDB.MoveFirst
0015iTestSaved = 0
0016Do Until rsCodeDB.EOF
0017 strRoutine = rsCodeDB.Fields(0)
0018 i = InStr(Code_Local, strRoutine)
0019 Do While i > 0
0020 'Ignore false positives
0021 strTest = Mid(Code_Local, i + Len(strRoutine), 1)
0022 'Check Following character
0023 If strTest = " " Or strTest = "(" Or strTest = Chr$(10) Then
0024 strTest = Mid(Code_Local, i - 1, 1)
0025 'And check preceeding character
0026 If strTest = " " Or strTest = "(" Or strTest = Chr$(10) Then
0027 'Find the line number
0028 j = i - 1
0029 strTest = ""
0030 Do Until strTest = Chr$(10) Or j = 1
0031 strTest = Mid(Code_Local, j, 1)
0032 j = j - 1
0033 Loop
0034 If j = 1 Then
0035 Else
0036 j = j + 2
0037 End If
0038 iTest = Val(Mid(Code_Local, j, 4))
0039 strTest = Trim(Mid(Code_Local, i + Len(Sub_Function), 2))
0040 strCheck = Mid(Code_Local, j + 4, i - j - 4)
0041 k = InStr(strCheck, "'") + InStr(strCheck, "Debug.Print") + InStr(strCheck, "MsgBox") 'Check for Comments, MsgBox or Debug ...
0042 'And Ignore reference to this in the Procedure Name (but allow for recursion - ie. ignore Line 1 or where just setting the return value of a function)
0043 If (strRoutine = Sub_Function) And (iTest = 1 Or strTest = "=") Then
0044 Else
0045 strTest = Trim(Mid(Code_Local, i + Len(Sub_Function), 2))
0046 If strTest = "=" Then
0047 Else
0048 'Check if this line has already been "done", or is a comment line, MsgBox or a debug line ...
0049 If Mid(Code_Local, j, 1) = "<" Or k > 0 Then
0050 i = i + 1
0051 Else
0052 'Update the database
0053 If iTestSaved <> iTest Then
0054 rsCodeLinksDB.AddNew
0055 rsCodeLinksDB.Fields(0) = Sub_Function
0056 rsCodeLinksDB.Fields(1) = iTest
0057 rsCodeLinksDB.Fields(2) = strRoutine
0058 rsCodeLinksDB.Update
0059 End If
0060 iTestSaved = iTest
0061 If Mid(Code_Local, j, 1) <> "<" Then
0062 'Update the Code line with a Name (if this line not already "bagged")
0063 'Also need to add a link to the called module (after finding its documentation Location)
0064 Code_Location = rsCodeDB.Fields(6)
0065 Code_Local = Left(Code_Local, j - 1) & "<A Name=""" & Sub_Function & "_" & iTest & """></A><A HREF=""" & SubSystem & "Documentation_Code_" & Code_Location & ".htm#" & strRoutine & """>" & Mid(Code_Local, j, 4) & "</A>" & Mid(Code_Local, j + 4, Len(Code_Local))
0066 'Adjust the cursor ...
0067 i = i + 11 + Len(iTest) + Len(strRoutine) + 28 + Len(Code_Location) + 4
0068 End If
0069 End If
0070 End If
0071 End If
0072 End If
0073 End If
0074 i = InStr(i + 1, Code_Local, strRoutine)
0075 Loop
0076 rsCodeDB.MoveNext
0077 iTestSaved = 0
0078Loop
0079If Code <> Code_Local Then
0080 'Update the Code database
0081 Code = Code_Local
0082 Set rsTableToUpdate = CurrentDb.OpenRecordset("Select Code from Code_Table WHERE Procedure_Name = """ & Sub_Function & """;")
0083 rsTableToUpdate.MoveFirst
0084 rsTableToUpdate.Edit
0085 rsTableToUpdate.Fields(0) = Code
0086 rsTableToUpdate.Update
0087End If
0088Sub_Function_Call_Checker = "OK"
0089End Function

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


© Theo Todman, June 2007 - Sept 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