Private Sub Project_Open(ByVal pj As MSProject.Project)
ThisProject.VBProject.Description = ThisProject.VBProject.Description 'While saving your file to Microsoft Project 98 format, Microsoft Project 2000 added this line to ensure that your VBA macros are loaded properly.
End Sub


Public Function SPEKU_SummeAufwand(Ressourcenangabe As String) As Variant
Dim s As String, i1 As Integer, i2 As Integer, su As Double, x As Double

    'Format der Ressourcenangabe: Name(PT), Name1(PT),..
    On Error GoTo SPEKU_SummeAufwand_ERR
    s = Ressourcenangabe
    If IsNumeric(s) Then
        SPEKU_SummeAufwand = CDbl(s)
        Exit Function
    End If

    While Len(s) > 0
        i1 = InStr(s, "(")
        If i1 = 0 Then
            s = ""
        Else
            i2 = InStr(s, ")")
            If i2 = 0 Or (i2 - i1 - 1) < 1 Then 'Fehler
                SPEKU_SummeAufwand = "#ERROR"
                Exit Function
            End If
            x = Mid(s, i1 + 1, i2 - i1 - 1)
            su = su + x
            If i2 < Len(s) Then
                s = Mid(s, i2 + 1)
            Else
                s = ""
            End If
        End If
    Wend
    SPEKU_SummeAufwand = su
    
SPEKU_SummeAufwand_Exit:
    Exit Function
    
SPEKU_SummeAufwand_ERR:
    SPEKU_SummeAufwand = Null
    Resume SPEKU_SummeAufwand_Exit


End Function

Private Sub Project_BeforeSave(ByVal pj As Project)
Dim i As Integer, ii As Integer, ResPT As Double, A() As Double
Dim LE As Integer, E As Integer, w As Double
Dim calc As Long

    ii = pj.Tasks.Count
    ReDim A(10)
    LE = 0  'Letzte Ebene
    For i = ii To 1 Step -1
        If Not (pj.Tasks(i) Is Nothing) Then
            E = pj.Tasks(i).OutlineLevel
            If E > UBound(A) Then ReDim Preserve A(E)
            ResPT = SPEKU_SummeAufwand(pj.Tasks(i).Text2)
            ResPT = ResPT + SPEKU_SummeAufwand(pj.Tasks(i).Text3)
            ResPT = ResPT + SPEKU_SummeAufwand(pj.Tasks(i).Text4)
            ResPT = ResPT + SPEKU_SummeAufwand(pj.Tasks(i).Text5)
            ResPT = ResPT + SPEKU_SummeAufwand(pj.Tasks(i).Text6)
            ResPT = ResPT + SPEKU_SummeAufwand(pj.Tasks(i).Text7)
    
            If E = LE Then
                A(E) = A(E) + ResPT
                pj.Tasks(i).Number1 = ResPT
            ElseIf E > LE Then
                A(E) = ResPT
                pj.Tasks(i).Number1 = ResPT
            Else
                pj.Tasks(i).Number1 = A(LE) + ResPT
                A(LE) = 0
                A(E) = A(E) + pj.Tasks(i).Number1
            End If
            LE = E
            w = pj.Tasks(i).Work / 60 / pj.HoursPerDay
            pj.Tasks(i).Text1 = IIf(pj.Tasks(i).Number1 = w, "ok", "DIFF")
        End If
    Next
End Sub