OK, I get the first milesotne MS1 (no predecessors) then I can get the successors MS1.1...MS1.n
When I know the successosr I join the IDs to locate valid steps between the milestones:
ID Criteria Step
001-002 Category = GF 10 days
001-002 Category = RT 20 days
001-003 Category = EM 15 days
Then I update the schedule using, the milestone ID, criteria and step value, I do this by iterating through the steps and building the SQL as I go:
Do While Not .eof
UPDATE Schedule SET Duration = " & intDur & " WHERE " & strCriteria & ";"
.movenext
Loop
This works, now I want to use 002 as a Milestone and isolate successors from the successor table then apply the appropriate SQL updates eg:
ID Criteria Step
002-004 Category = GF 50 days
then
003-005 Category = RT 25 days
When I do this recursive traversal I want to do it breadth first rather than depth first.
CODE AS FOLLOWS:
Warning that there are additional factors such as programme and milestone template which are included in outer iterations.
Sub ModelAvailableSchedule()
On Error GoTo ErrorHandler
'---Recordset for acquisition of milestone labels, from progs-templates-milestones
Dim rst1 As Recordset
Dim rst2 As Recordset
Dim rst3 As Recordset
Dim rst4 As Recordset
'---Key values used in insert statements to relate transposed records to appropriate milestones etc
Dim intMSTmpltID As Long
Dim intMSID As Long
Dim intFirstMS_ID As Long
Dim intSecondMS_ID As Long
'---Counter
Dim intCnt As Integer
'---Step values
Dim intStepVal As Integer
Dim intStepValSlipped As Integer
'---Field labels, names etc
Dim strProgLbl As String
Dim strMS_ModelField As String
Dim strMS_FC_ModelField As String
Dim strMS_Act_ModelField As String
Dim strPotKey As String
Dim strMSStepID As String
Dim strGrouper As String
'-----------------------------------------------------------------------------------------------------------
'---
'---Model the available schedule
'---
'---In order to model the available schedule the dates for Phase Dates are ammended in ths current schedule.
'---This is done by updating the Phase dates for all schedule items where the various criteria specified in
'---the step form are met and where the milestone criteria are matched
'-----------------------------------------------------------------------------------------------------------
'---
'---Logic outlined as follows:
'--- 1. Get the list of templates and iterate logic across each template
'--- 2. Get the first milestone in each template, ie that with no predecessors
'---
'---Switch off echo and on hourglass
'---DoCmd.Hourglass True
'---Application.Echo False
Set dbs = DBEngine(0)(0)
'---Get a list of templates that exist in this schedule, this avoids iterations across templates for which
'---there are no records
strSQL = "SELECT DISTINCT Template " & _
"FROM TMP_ArtSch_Transposed " & _
"INNER JOIN SCH_Milestone ON TMP_ArtSch_Transposed.Template = SCH_Milestone.MS_Tmplt_ID;"
Set rst1 = dbs.OpenRecordset(strSQL)
With rst1
.MoveLast
.MoveFirst
Do While Not .EOF
'---Reference for tempalte
intMSTmpltID = !Template
'---Set up SQL for selection of the first milestone ie that with no predecessors, generally this is
'---Issued and the step will be to acquired, there are special condition for this step as not all
'--activities have been built into the modelling process and data structure
strSQL = "SELECT SCH_Milestone.MS_ID, MS_Tmplt_ID, MS_Name, MS_Pre_ID, MS_FC_ModelField, MS_Act_ModelField " & _
"FROM SCH_Milestone LEFT JOIN SCH_MS_Pre ON SCH_Milestone.MS_ID = SCH_MS_Pre.MS_ID " & _
"WHERE ((MS_Tmplt_ID = " & intMSTmpltID & ") AND (MS_Pre_ID Is Null) AND " & _
"(MS_FC_ModelField <> 'NA') AND (MS_Act_ModelField <> 'NA'));"
Set rst2 = dbs.OpenRecordset(strSQL)
With rst2
.MoveLast
.MoveFirst
intFirstMS_ID = !MS_ID
End With
'---Now get all consequesnt milestones, within this operation the update of the schedule must take place
'---Where there are multiple successors to a milestone only push the milestone forwards where the push
'---leaves the milestone in the future and does not pull it back, this would have the effect of making
'---another activitie's duration shorter
'---Switch off echo and on hourglass
DoCmd.Hourglass (False)
Application.Echo (True)
strSQL = "SELECT MSTmplt_ID, MS_ID, MS_Suc_ID " & _
"FROM SCH_MS_Suc " & _
"WHERE ((MSTmplt_ID = " & intMSTmpltID & ") AND (MS_ID = " & intFirstMS_ID & "));"
Set rst2 = dbs.OpenRecordset(strSQL)
With rst2
.MoveLast
.MoveFirst
Do While Not .EOF
intSecondMS_ID = !MS_Suc_ID
'---Concatenate first milestone ID with second milestone ID and use this string to identify all
'---successor step sets defining the transition between the milestones, these can be selected by
'---order of step set precedence, this means that the steps are applied in order of priority and
'---thus any sets that are not exclusive can be applied ahead of exclusive sets
strMSStepID = Format(intFirstMS_ID, "000") & "-" & Format(intSecondMS_ID, "000")
strSQL = "SELECT DISTINCT Left([MS_SucStep_ID],7) AS MS_Step_ID, StepGrouper, StepGrouperPrecedence " & _
"FROM SCH_MS_SucStep " & _
"WHERE (Left([MS_SucStep_ID], 7) = '" & strMSStepID & "') " & _
"ORDER BY StepGrouperPrecedence;"
Set rst3 = dbs.OpenRecordset(strSQL)
With rst3
.MoveLast
.MoveFirst
Do While Not .EOF
'---Reference to:
'--- 1. Milestone from - to
'--- 2. Step grouper
'---These represent a pseudo foreign key for grouping milestone steps
'---Having this it is possible to now build up the SQL: string for each step in the
'---correct order using the SQL parts in the cardinal order and get the step in days
'---Then an update statement to move the TO milestone into the future can be obtained
strGrouper = !StepGrouper
strSQL = "SELECT DISTINCT Left([MS_SucStep_ID],7) AS MS_Step_ID, StepGrouper, CardinalPos, SQLPart, StepVal, StepValueSlipped " & _
"FROM SCH_MS_SucStep " & _
"WHERE ((Left([MS_SucStep_ID],7) = '" & strMSStepID & "') AND " & _
"(StepGrouper ='" & strGrouper & "')) " & _
"ORDER BY CardinalPos;"
Set rst4 = dbs.OpenRecordset(strSQL)
With rst4
.MoveLast
.MoveFirst
strSQL = ""
intStepVal = !StepVal
intStepValSlipped = !StepValueSlipped
strGrouper = !StepGrouper
Do While Not .EOF
strSQL = strSQL & !SQLPart
.MoveNext
Loop
strSQL = "UPDATE TMP_ArtSch_Transposed " & _
"SET " & _
"ModelMS_Mdl_Dur = " & intStepVal & ", " & _
"ModelMS_Mdl_DurSlip = " & intStepValSlipped & " " & _
"WHERE " & strSQL & " AND ((ModelMS_ID = " & intSecondMS_ID & ") AND (ModelThis = TRUE));"
dbs.Execute strSQL
Debug.Print strSQL
End With
.MoveNext
Loop
End With
.MoveNext
Loop
End With
'---Move to next template in list of valid templates
.MoveNext
'---Loop to next template in valid templates recordset
Loop
'---End with for templates recordset
End With
DoCmd.Hourglass False
Application.Echo True
'---Get out here
ExitPoint:
Set rst = Nothing
Set dbs = DBEngine(0)(0)
For Each r In dbs.Recordsets
r.Close
Next r
Set dbs = Nothing
DoCmd.Hourglass False
Application.Echo True
SysMsg = SysCmd(acSysCmdClearStatus)
Exit Sub
'---Handle errors here
ErrorHandler:
intErr = Err.Number
Select Case intErr
Case Is > 0
strRtnName = "ModelAvailableSchedule"
Call HandleAllErrorrs(intErr, strRtnName)
Resume ExitPoint
End Select
End Sub
Troy Vinson
Trading as IT Supportman
