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中的列表）然后循环遍历这些任务来解决。我在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

改进MS Project VB / VBA任务创建

1 个答案: