Verbesserung MS Project VB/VBA Aufgabenerstellung

Question

Im Moment habe ich etwas Code, der neue Aufgaben erstellt, aber es ist wirklich fehlerhaft und inkonsistent.

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 

Es ist zu weit zu gehen scheint, wenn durch die ausgewählten Aufgaben Looping und schafft 1 Aufgabe zu viele, ich um dieses arbeitete, indem Sie zurück und die zusätzliche Aufgabe zu löschen, aber es mir scheint nicht, wie die beste Lösung .

Ich weiß, dass dieses Bit Code in VB.net ist, aber ich kann auch mit VBA arbeiten.

Gibt es eine bessere Möglichkeit, neue Aufgaben zu erstellen und Werte zuzuweisen?

Answer 1

Das Problem mit der Extra-Aufgabe kann gelöst werden, indem eine Sammlung (oder eine Liste in .net) ausgewählter Aufgaben gespeichert und dann diese durchlaufen werden. Ich poste die Lösung in VBA, da dies wahrscheinlich für andere Zuschauer am relevantesten ist; Ich kann eine vb.net Version bei Bedarf veröffentlichen.

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 

ich ein paar Dinge geändert: 1), anstatt das Startfeld Hartcodierung, eine Aufgabe Beziehung verwenden es Aufgabe des mit ihm zu halten, wenn die Aufgabe bewegt; 2) Da Tasks mit Null-Dauer keine Arbeit haben, ist es nicht notwendig, Ressourcen hinzuzufügen.

UPDATE

Hier ist die 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