改进 MS Project VB/VBA 任务创建

Question

目前我有一些创建新任务的代码，但它确实存在错误且不一致。

Public Sub Create_milestones()
    proj = Globals.ThisAddIn.Application.ActiveProject

    Dim myTask As MSProject.Task

    Application.ScreenUpdating = False

    For Each myTask In Application.ActiveSelection.Tasks
        Application.SelectTaskField(Row:=1, Column:="Name")
        Application.InsertTask()
        Application.SetTaskField(Field:="Duration", Value:="0")
        Application.SetTaskField(Field:="Start", Value:=myTask.Finish)
        Application.SetTaskField(Field:="Name", Value:=myTask.Name & " - Milestone")
        Application.SetTaskField(Field:="Resource Names", Value:=myTask.ResourceNames)
        Application.SetTaskField(Field:="Text3", Value:="Milestone")
        Application.GanttBarFormat(GanttStyle:=3, StartShape:=13, StartType:=0, StartColor:=255, MiddleShape:=0, MiddlePattern:=0, MiddleColor:=255, EndShape:=0, EndColor:=255, EndType:=0)
        Application.SelectTaskField(Row:=1, Column:="Name")
    Next
    Application.SelectTaskField(Row:=-1, Column:="Name")
    Application.SelectRow(Row:=0)
    Application.RowDelete()

    Application.ScreenUpdating = True

    MsgBox("Done")
End Sub

循环遍历选定任务并创建太多任务时似乎走得太远了，我通过返回并删除额外任务来解决这个问题，但这对我来说似乎不是最好的解决方案。

我意识到这段代码在 VB.net 中，但我也可以使用 VBA。

有没有更好的方法来为新任务创建和分配价值？

Answer 1

可以通过存储选定任务的集合（或 .net 中的列表）然后循环遍历这些任务来解决额外任务的问题。我在 VBA 中发布解决方案，因为这可能与其他查看者最相关；如果需要，我可以发布一个 vb.net 版本。

Application.ScreenUpdating = False

Dim proj As Project
Set proj = Application.ActiveProject

Dim myTask As Task
Dim colTasks As New Collection
For Each myTask In Application.ActiveSelection.Tasks
    colTasks.Add myTask, CStr(myTask.UniqueID)
Next myTask

Dim i As Object
For Each i In colTasks
    Set myTask = ActiveProject.Tasks.UniqueID(i)
    Dim newTask As Task
    Set newTask = ActiveProject.Tasks.Add(myTask.Name & " - Milestone", myTask.ID + 1)
    newTask.Duration = 0
    newTask.Predecessors = myTask.ID & "FF"
    newTask.Text3 = "Milestone"
    newTask.ResourceNames = myTask.ResourceNames
    Application.SelectRow newTask.ID, False
    Application.GanttBarFormat GanttStyle:=3, StartShape:=13, StartType:=0, StartColor:=255, MiddleShape:=0, MiddlePattern:=0, MiddleColor:=255, EndShape:=0, EndColor:=255, EndType:=0
Next

Application.SelectRow colTasks(1), False
Application.SelectTaskField Row:=0, Column:="Name"
Application.ScreenUpdating = True

我改变了一些东西：1）不是硬编码开始字段，而是在任务移动时使用任务关系来保持它与它的任务； 2）由于零工期任务没有工作，所以不需要添加资源。

更新

这是 vb.net 版本：

        Dim ProjApp As MSProject.Application = Globals.ThisAddIn.Application
        ProjApp.ScreenUpdating = False

        Dim proj As MSProject.Project = ProjApp.ActiveProject

        Dim selTasks As New List(Of MSProject.Task)
        For Each myTask As MSProject.Task In ProjApp.ActiveSelection.Tasks
            selTasks.Add(myTask)
        Next myTask

        For Each myTask In selTasks
            Dim newTask As MSProject.Task = proj.Tasks.Add(myTask.Name & " - Milestone", myTask.ID + 1)
            newTask.Duration = 0
            newTask.Predecessors = myTask.ID & "FF"
            newTask.Text3 = "Milestone"
            newTask.ResourceNames = myTask.ResourceNames
            ProjApp.SelectRow(newTask.ID, False)
            ProjApp.GanttBarFormat(GanttStyle:=3, StartShape:=13, StartType:=0, StartColor:=255, MiddleShape:=0, MiddlePattern:=0, MiddleColor:=255, EndShape:=0, EndColor:=255, EndType:=0)
        Next

        ProjApp.SelectRow(selTasks(0).ID, False)
        ProjApp.SelectTaskField(Row:=0, Column:="Name")
        ProjApp.ScreenUpdating = True