如何使用 VBA 更新 Microsoft Project 子项目

Question

我们正在尝试按照here 和here 的建议使用VBA 更新时间表子项目中的状态日期。理想情况下，我们希望在执行此操作时保持文件关闭，但如果这不是绝对可行的，我们愿意接受建议。

相关代码如下：

If ActiveProject.Subprojects.count > 0 Then
    Dim msg: msg = MsgBox("Change Status Date for unopened Subprojects?", vbYesNo, "Change Status Dates for Unopened Subprojects?")
    Dim subp As SubProject
    If msg = vbYes Then
        Application.StatusBar = "Updating Sub-Projects..."
        For Each subp In ActiveProject.Subprojects
            subp.SourceProject.StatusDate = newDate
            subp.SourceProject.SaveAs subp.SourceProject.Name
        Next
    End If
End If

这似乎可以工作，但是当我们打开子项目文件时，状态日期并没有改变（如项目 > 状态 > 状态日期所示）。以下日期前后相同：

同样无效的替代方案。

1. 我们已经尝试设置Projects(subp.SourceProject.Name).StatusDate:

If ActiveProject.Subprojects.count > 0 Then
    Dim msg: msg = MsgBox("Change Status Date for unopened Subprojects?", vbYesNo, "Change Status Dates for Unopened Subprojects?")
    Dim subp As SubProject
    If msg = vbYes Then
        Application.StatusBar = "Updating Sub-Projects..."
        For Each subp In ActiveProject.Subprojects
            Projects(subp.SourceProject.Name).StatusDate = newDate
            subp.SourceProject.SaveAs subp.SourceProject.Name
        Next
    End If
End If

1. 我们尝试先打开子项目，然后更改值（我们尝试过 FileOpen 和 FileOpenEx）：

If ActiveProject.Subprojects.count > 0 Then
    Dim msg: msg = MsgBox("Change Status Date for unopened Subprojects?", vbYesNo, "Change Status Dates for Unopened Subprojects?")
    Dim subp As SubProject
    If msg = vbYes Then
        Application.StatusBar = "Updating Sub-Projects..."
        For Each subp In ActiveProject.Subprojects
            FileOpen subp.SourceProject.Path
            subp.SourceProject.StatusDate = newDate
            FileClose pjSave
        Next
    End If
End If

1. 然后我们尝试使用以下各种方式保存子项目：

• subp.SourceProject.SaveAs subp.SourceProject.Name

• Projects(subp.SourceProject.path).SaveAs subp.SourceProject.Name

作为一个有趣的数据点，我们确实注意到给定子项目的 SourceProject.StatusDate 和 Projects(subp.SourceProject.Name).StatusDate 都是我们设置的，即使子项目在 MSP 中打开后不会反映接口中的值。

注意：我们已经尝试关闭/重新打开和手动保存所有（用户输入）。不行。

欢迎提出任何建议。

编辑#1

请注意，我们还尝试使用两种方法在循环之后保存主计划。

首先，导致保存的代码：

    'save name of Master Schedule to imsProj
    dim imsProj as string: imsProj = ActiveProj.Name 
    If ActiveProject.Subprojects.count > 0 Then
         'Here is where we run the above loop
    End If
    
    'Ensure the Master Schedule is the active project
    Projects(imsProj).Activate

    'Master Schedule save goes here. See below.

然后：

保存方法一

    'Save all open Projects, including master
    For i = 1 To Projects.count
        Projects(i).SaveAs Projects(i).Name
    Next i

保存方法二：

FileSave

都不行。

MSP 中是否有我们没有考虑的设置？

Answer 1

不要尝试单独保存每个子项目，而是在最后保存整个主项目。关闭警报可防止每个子项目弹出确认框。

Sub SetSubProjectStatusDate()

Dim newDate As Date
newDate = #1/11/2022#

If ActiveProject.Subprojects.Count > 0 Then
    Dim msg As VbMsgBoxResult
    msg = MsgBox("Change Status Date for unopened Subprojects?", vbYesNo + vbQuestion _
        , "Change Status Dates?")
    If msg = vbYes Then
        Application.StatusBar = "Updating Sub-Projects..."
        Dim subp As Subproject
        For Each subp In ActiveProject.Subprojects
            subp.SourceProject.StatusDate = newDate
        Next
        DisplayAlerts = False
        FileSave
        DisplayAlerts = True
    End If
End If

End Sub

Answer 2

这非常令人沮丧，但似乎 IMS 及其子项目以某种方式损坏了。除了状态日期的显示方式之外，没有明显的原因，没有明显的影响。使用一组新的 MPP 解决了这个问题。

这是最终的工作代码：

If ActiveProject.Subprojects.count > 0 Then
    Dim msg: msg = MsgBox("Change Status Date for unopened Subprojects?", vbYesNo, "Change Status Dates for Unopened Subprojects?")
    Dim subp As SubProject
    If msg = vbYes Then
        Application.StatusBar = "Updating Sub-Projects..."
        For Each subp In ActiveProject.Subprojects
            subp.SourceProject.StatusDate = temp
        Next
    End If
End If

Projects(imsProj).Activate

FileSave