改进 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

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

我知道这段代码在 VB.net 中，但我也可以使用 VBA。

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

Answer 1

额外任务的问题可以通过存储选定任务的集合（或 .net 中的列表）然后循环遍历这些任务来解决。我 post 在 VBA 中寻找解决方案，因为这可能与其他观众最相关；如果需要，我可以 post 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

改进 MS Project VB/VBA 任务创建

improving MS Project VB/VBA task creation

vb.net

vba

ms-project