improving MS Project VB/VBA task creation

Question

At the moment I have some code that creates new tasks, but it's really buggy and inconsistent.

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

It seems to go too far when looping through the selected tasks and creates 1 task too many, I worked around this by going back and deleting the extra task but it doesn't seem like the best solution to me.

I realise this bit of code is in VB.net but I can work with VBA too.

Is there a better way to create and assign values to new tasks?

Answer 1

The problem with the extra task can be solved by storing a collection (or list in .net) of selected tasks and then looping through those. I'm posting the solution in VBA since that is likely to be the most relevant to other viewers; I can post a vb.net version if needed.

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

I changed a few things: 1) rather than hard-coding the start field, use a task relationship to keep it with it's task when the task moves; 2) since zero-duration tasks have no work, it is not necessary to add resources.

UPDATE

Here's the vb.net version:

        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