by Ron A. Romero (2 Submissions)
Category: Databases/Data Access/DAO/ADO
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Fri 18th January 2002
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Rollup task for MS Project2000 in MS Access database. Updates the calculations for an individuals project table, and then for the whole
VBcoders
Dim rst(4) As DAO.Recordset
Dim dbs As DAO.Database
Dim w As Integer
Dim X As Long
Dim Y As Integer
Dim z As Integer
Dim strParentOutlineNum As String
Dim strParentOutlineNumOrig As String
Dim b As Integer
Dim intCountOfRollup As Long
Dim strOutlineCriteria As String
Dim CostField As String
'==================================================================
'This function calculates all of the Actual Cost for the user's
'individual table, and for the whole project.
'It uses the Outline numbers to determine what is to be
'calculated to where.
'==================================================================
'Determine if this i a user table or project table to
'calculate and change the query fields accordingly.
If tblName = "MSP_TASKS" Then
CostField = "TASK_ACWP"
Else
CostField = "ActualCost"
End If
Set dbs = CurrentDb
Set rst(1) = dbs.OpenRecordset("SELECT * FROM " & tblName _
& " ORDER By TASK_OUTLINE_NUM DESC;")
strParentOutlineNum = rst(1)!TASK_OUTLINE_NUM
'This counts the length of the outline number to determain
'the length of the string to search backwards with.
Y = Len(rst(1)!TASK_OUTLINE_NUM)
w = 0
rst(1).Close
GoSub RotateNumber
'Trim every digit begining with the last and back, to determain a search
'string to retrieve all actual cost numbers within that outline number.
CalcCriteria:
Y = Len(strParentOutlineNum)
w = 0
Do Until Y = 0
If Mid(strParentOutlineNum, Y, 1) = "." Then
strOutlineCriteria = Left(strParentOutlineNum, Y) & "*"
strParentOutlineNum = Left(strParentOutlineNum, Y - 1)
Debug.Print " Parent Outline Criteria:" & " " & strParentOutlineNum
If w = 0 Then
w = w + 1
End If
Exit Do
Else
strParentOutlineNum = Left(strParentOutlineNum, Y - 1)
w = w + 1
Y = Y - 1
End If
Loop
'Counts all records and stores them
'in the variable intCountOfRollup
Set rst(2) = dbs.OpenRecordset("SELECT " & CostField & ",TASK_OUTLINE_NUM FROM " & tblName _
& " WHERE task_outline_num LIKE '" & strOutlineCriteria & "';")
b = Len(strOutlineCriteria)
intCountOfRollup = 0
Do Until rst(2).EOF
COuntline = rst(2)!TASK_OUTLINE_NUM
If Len(COuntline) > b + 1 Then
rst(2).MoveNext
Else
If CostField = "TASK_ACWP" Then
X = rst(2)!TASK_ACWP
intCountOfRollup = intCountOfRollup + rst(2)!TASK_ACWP
rst(2).MoveNext
Else
X = rst(2)!ActualCost
intCountOfRollup = intCountOfRollup + rst(2)!ActualCost
rst(2).MoveNext
End If
End If
Loop
rst(2).Close
'Parses the wildcard and "." to
'create a parent number for the next lookup
strParentOutlineNum = Left(strOutlineCriteria, Len(strOutlineCriteria) - 2)
'Opens a recordset and puts the total
'of intCountOfRollup in the 'CostField' Field.
Set rst(3) = dbs.OpenRecordset("SELECT " & CostField & " FROM " & tblName _
& " WHERE task_outline_num like '" & strParentOutlineNum & "';")
If rst(3).RecordCount = 0 Then
GoTo RotateNumber:
Else
With rst(3)
If CostField = "TASK_ACWP" Then
.Edit
!TASK_ACWP = intCountOfRollup
.Update
.MoveNext
Else
.Edit
!ActualCost = intCountOfRollup
.Update
.MoveNext
End If
End With
End If
rst(3).Close
'Rotates the Parent number for the
'next search criteria.
RotateNumber:
intRowCount = intRowCount = -1
strParentOutlineNumOrig = strParentOutlineNum
Y = Len(strParentOutlineNum)
w = 0
'Decrement the next parent digit if the last
'outline number is 0. This is used for numbers
'2 and up. See next level for 1 and down.
If Right(strParentOutlineNum, 1) < 1 Then
w = 1
GoTo NextLevel
End If
Do Until Y = 0
If Mid(strParentOutlineNum, Y, 1) = "." Then
strParentOutlineNum = Left(strParentOutlineNum, Y)
z = Right(strParentOutlineNumOrig, w) - 1
strParentOutlineNum = strParentOutlineNum & z
Debug.Print " Parent Outline Criteria: " & strParentOutlineNum
Exit Do
Else
w = w + 1
Y = Y - 1
strParentOutlineNum = Left(strParentOutlineNum, Y)
End If
Loop
NextLevel:
'This does the same as Rotate number, but also determains if
'you are at the beginning of the outline numbers
If Right(strParentOutlineNum, 2) = ".0" Then
If Len(strParentOutlineNum) = 2 Then
Exit Function
Else
strParentOutlineNum = Left(strParentOutlineNum, Len(strParentOutlineNum) - 1)
GoTo CalcCriteria
End If
ElseIf Right(strParentOutlineNum, w) = 0 Then
Y = Len(strParentOutlineNum)
strParentOutlineNum = Left(strParentOutlineNum, Y - w - 1)
z = Right(strParentOutlineNum, w) - 1
Y = Y - 2
strParentOutlineNum = Left(strParentOutlineNum, Y - w) & z & "."
Debug.Print " Parent Outline Criteria: " & strParentOutlineNum
ElseIf strParentOutlineNum = "1.1" Then
strParentOutlineNum = "1."
Exit Function
ElseIf strParentOutlineNum = "1" Then
Exit Function
Else
strParentOutlineNum = strParentOutlineNum & "."
End If
'Opens the recordset with the next number in rotation
'and determains if the outline number is assigned
'for calculation. If not, rotate to the next number.
FindRows:
Set rst(4) = dbs.OpenRecordset("select " & CostField & ",task_outline_num from " & tblName _
& " where task_outline_num like '" & strParentOutlineNum & "*' " _
& "order by TASK_OUTLINE_NUM desc;")
If rst(4).RecordCount = 0 Then
strParentOutlineNum = Left(strParentOutlineNum, Len(strParentOutlineNum) - 1)
rst(4).Close
GoSub RotateNumber:
Else
strParentOutlineNum = rst(4)!TASK_OUTLINE_NUM
rst(4).Close
GoSub CalcCriteria:
End If
End Function
No comments have been posted about Rollup task for MS Project2000 in MS Access database. Updates the calculations for an individuals p. Why not be the first to post a comment about Rollup task for MS Project2000 in MS Access database. Updates the calculations for an individuals p.
