改进了 MS 项目 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