Project: Export PSP in Office / Export WBS to Office

2019-05-19 | Barbara.Henhapl
  1. Deutsch
  2. English
  3. Code: Referenzen beim Öffnen aktivieren / Enable References on Open
  4. Code: Referenzen aktivieren / Enable References
  5. Code: Export PSP / Export WBS

Deutsch

Leider bietet Project keine Möglichkeit, die Planung als PSP zu exportieren. Diese Anforderung wird aber oft in Foren und auch von Kunden gestellt. Ich stelle hier ein Makro bereit, dass eine SmartArt Grafik in Excel, Word und PowerPoint bereitstellt. Um aus Project eine dieser Officeanwendungen anzuprechen, müssen Verweise für die jeweilige Anwenung gesetzt sein. Die Verweise sind optimalerweise in der globalen Vorlage zu setzen. Beim Arbeiten ohne Verbindung zu Project Online / Project Server ist das die Datei Global.mpt. Diese Datei enthält alle Objekte, die auf dem Rechner für alle Projekte zur Verfügung stehen. Bei Verbindung mit Project Online / Project Server sind die Verweise in der Enterprise Global zu aktivieren.

Verweise manuell aktivieren

Diese Verweise können manuell aktiviert werden. Öffnen Sie dazu den Visual Basic Editor. Stellen Sie sicher, dass ProjectGlobal(Global.MPT) bzw. VBAProject (Ausgecheckte Enterprise-Global) aktiviert ist. Öffnen Sie den Verweis-Dialog mit Extras – Verweise.

SNAGHTMLd30e8e4

Es werden die Verweise für die drei Officeanwendungen und Microsoft Office benötigt. Die Versionsnummer kann sich auf Ihrem Rechner unterscheiden, wählen Sie die aktuellste Version, sofern mehr als eine zur Verfügung steht.

image

Verweise per Makro aktivieren

Die Verweise können aber auch über ein Makro gesetzt werden, dass Sie bei jedem Öffnen einen Projekts ausführen. Wenn Sie diese Lösung bevorzugen, fügen Sie den Code: Referenzen beim Öffnen aktivieren / Enable References on Open in ThisProject der entsprechenden Umgebung ein. Dieser Code wird bei jedem Öffnen ausgeführt und ruft die Prozedur zum Setzen der Verweise auf.

SNAGHTMLd3ce7d0

Fügen Sie den Code: Referenzen aktivieren / Enable References in ein vorhandenes oder ein neues Modul ein. Diese Prozedur repariert oder setzt die erforderlichen Referenzen, sofern eine Änderung erforderlich ist.

Wenn sichergestellt ist, dass die Referenzen vorhanden sind (manuell oder per Makro), können Sie das Makro aus Code: Export PSP / Export WBS  in ein vorhandenes oder neues Modul einfügen. Dieses Makro lässt Sie die Zielanwendung (Word, Excel oder PowerPoint) auswählen. Es exportiert alle Vorgänge als PSP, für die das Feld Attribut1 auf Ja gesetzt ist. Sie können das ändern, indem Sie die globale Konstante C_TaskExportValue auf False ändern. Die Prüfung für dieses Feld ist implementiert, um den Export für sehr große Projekte einschränken zu können.

image

Nach Start des Makros für Word ergibt sich folgendes Bild:

image

In Makros implementieren / Implement Macros wird beschrieben, wie ein Makro in Project übernommen werden kann. Mehr Beispielmakros sind unter VBA zu finden.

English

Unfortunately, Project does not provide a way to export the planning as a WBS. However, this requirement is often asked in forums and also by customers. Here's a macro that provides a SmartArt graphic in Excel, Word, and PowerPoint. In order to run one of these office applications from Project, references must be set to the respective application. The references should ideally be placed in the global template. When working without connecting to Project Online / Project Server, this is the Global.mpt file. This file contains all the objects that are available on the computer for all projects. When connecting to Project Online / Project Server, you must enable the references in Enterprise Global.

Activate References Manually

These references can be activated manually. Open the Visual Basic Editor. Make sure that ProjectGlobal (Global.MPT) or VBAProject (Checked-Out Enterprise Global) is enabled. Open the References dialog with Tools - References.

image

The references for the three office applications and Microsoft Office are needed. The version number may differ on your machine, choose the latest version, if more than one is available.

image

Active References by Macro

Paste the Code: Enable References / Enable References in an existing or a new module. This procedure repairs or sets the needed references if a change is required.
If it is guaranteed that the references are present (manually or by macro), you can insert the macro from Code: Export PSP / Export WBS into an existing or new module. This macro lets you select the target application (Word, Excel or PowerPoint). It exports all operations as PSP for which Flag1 field is set to Yes. You can change this behavior by changing the global constant C_TaskExportValue to False. The check for this field is implemented to limit export for very large projects.

image

Running this macro for Word will provide the following:

image

Implementing Macros / Implement Macros describes how to apply a macro to Project. More sample code is available at VBA.

Code: Referenzen beim Öffnen aktivieren / Enable References on Open

Private Sub Project_Open(ByVal pj As Project)
    Call EnableReferences
    End Sub
    

Code: Referenzen aktivieren / Enable References

'Constants and Variables

    Global Const c_Office = "{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}"
    Global Const c_Excel = "{00020813-0000-0000-C000-000000000046}"
    Global Const c_Word = "{00020905-0000-0000-C000-000000000046}"
    Global Const c_PowerPoint = "{91493440-5A91-11CF-8700-00AA0060263B}"
    
    
    Sub EnableReferences()
    '***********************************************************************************
    'Code is provided “AS IS” without warranty of any kind, either expressed or implied,
    'including but not limited to the implied warranties of merchantability and/or
    'fitness for a particular purpose.
    '***********************************************************************************
    
    'This Procedure will not create the WBSChart, but enable all references
    'necessary for creating chart. References have to be set befor calling
    'procedure to actually create the chart
    'If references are set manually, this procedure can be omitted
    
    Dim strGUID As Variant
    Dim theRefs As Variant
    Dim theRef As Variant
    Dim i As Long
    
    '*****************************************************************************
    '**** Set references for SmartArt, Excel, Word and Powerpoint
    '*****************************************************************************
         
    Set theRefs = Application.VBE.VBProjects(1).References
    
    With theRefs
    
        '****Remove broken references
        For i = theRefs.Count To 1 Step -1
            Set theRef = .Item(i)
            If theRef.isbroken = True Then
                .References.Remove theRef
            End If
        Next i
        
        
        '****Errors have to be omitted in this case
        On Error Resume Next
        
        
        
        'Office
        .AddFromGuid Guid:=c_Office, major:=1, Minor:=0
        'Application.VBE.ActiveVBProject.References.AddFromGuid Guid:=c_Office, major:=1, Minor:=0
        'Evaluate error
        Select Case Err.Number
        Case 32813
             'Reference already set, no action required
        Case vbNullString
             'Reference successfully set
        Case Else
             'Error while setting reference - exit sub
             GoTo Ref_Error
        End Select
        
        
        'Excel
        .AddFromGuid Guid:=c_Excel, major:=1, Minor:=0
        'Evaluate error
        Select Case Err.Number
        Case 32813
             'Reference already set, no action required
        Case vbNullString
             'Reference successfully set
        Case Else
             'Error while setting reference - exit sub
             GoTo Ref_Error
        End Select
        
        
        'Word
        .AddFromGuid Guid:=c_Word, major:=1, Minor:=0
        'Fehler interpretieren
        Select Case Err.Number
        Case 32813
             'Referenz schon gesetzt - keine Aktivität erforderlich
        Case vbNullString
             'Referenz ohne Problem gesetzt
        Case Else
             'Unbekannter Fehler - Abbruch
             GoTo Ref_Error
        End Select
        
        
        'PowerPoint
        .AddFromGuid Guid:=c_PowerPoint, major:=1, Minor:=0
        'Evaluate error
        Select Case Err.Number
        Case 32813
             'Reference already set, no action required
        Case vbNullString
             'Reference successfully set
        Case Else
             'Error while setting reference - exit sub
             GoTo Ref_Error
        End Select
    
    End With
    '****Re-enable errors
    On Error GoTo 0
    
    Exit Sub
    Ref_Error:
            MsgBox "There was an issue activating" & vbNewLine _
            & "a required reference." & vbNewLine _
            & "Macro ended!", vbCritical + vbOKOnly, "Error!"
            Exit Sub
    End Sub
    

Code: Export PSP / Export WBS

Global Const c_TaskExportValue = True   'Define if Flag1 has to be true or false to be exported
Sub WBSChart()

'***********************************************************************************
'Code is provided “AS IS” without warranty of any kind, either expressed or implied,
'including but not limited to the implied warranties of merchantability and/or
'fitness for a particular purpose.
'***********************************************************************************

Dim obj_App         As Object
Dim obj_File        As Object
Dim obj_Target      As Object

Dim oSAlayout       As Office.SmartArtLayout

Dim obj_Shape       As Object

Dim oshp            As SmartArt

Dim v_App           As String

Dim P               As Project
Dim T               As Task

'****Get target application
v_App = "Please select target application for WBS Export" & vbCrLf
v_App = v_App & "1 - Word" & vbCrLf
v_App = v_App & "2 - Excel" & vbCrLf
v_App = v_App & "3 - PowerPoint" & vbCrLf
v_App = InputBox(v_App, "Target Application")

Select Case v_App
    Case ""
        MsgBox "No application selected. Macro will be terminated"
        Exit Sub
    Case "1"
        v_App = "Word"
    Case "2"
        v_App = "Excel"
    Case "3"
        v_App = "PowerPoint"
    Case Else
        MsgBox "Invalid input. Macro will be terminated"
        Exit Sub
End Select

Set P = ActiveProject

On Error Resume Next
Select Case v_App
    Case "Excel"
        Set obj_App = GetObject(, "Excel.Application")
        On Error GoTo 0
        If obj_App Is Nothing Then
            Set obj_App = CreateObject("Excel.Application")
        End If
        obj_App.Visible = True
        On Error Resume Next
        Set obj_File = obj_App.ActiveWorkbook
        On Error GoTo 0
        If obj_File Is Nothing Then
            Set obj_File = obj_App.Workbooks.Add
            'New workbook, we can use default sheet
            Set obj_Target = obj_File.ActiveSheet
        Else
            'Existing workbook, get a new sheet to avoid overwrite
            Set obj_Target = obj_File.Sheets.Add
        End If
        Set oSAlayout = obj_App.SmartArtLayouts("urn:microsoft.com/office/officeart/2005/8/layout/orgChart1")
        Set obj_Shape = obj_Target.Shapes.AddSmartArt(oSAlayout)
    Case "Word"
        Set obj_App = GetObject(, "Word.Application")
        On Error GoTo 0
        If obj_App Is Nothing Then
            Set obj_App = CreateObject("Word.Application")
        End If
        obj_App.Visible = True
        On Error Resume Next
        Set obj_File = obj_App.ActiveDocument
        On Error GoTo 0
        If obj_File Is Nothing Then
            Set obj_File = obj_App.Documents.Add
        End If
        'Get end of document
        Set obj_Target = obj_File.Range(obj_File.Range.End - 1, obj_File.Range.End)
        'add a new line in document
        obj_Target = vbCrLf
        Set obj_Target = obj_File.Range(obj_File.Range.End - 1, obj_File.Range.End)
        Set oSAlayout = obj_App.SmartArtLayouts("urn:microsoft.com/office/officeart/2005/8/layout/orgChart1")
        Set obj_Shape = obj_File.InlineShapes.AddSmartArt(oSAlayout)
    Case "PowerPoint"
        
        Set obj_App = GetObject(, "PowerPoint.Application")
        On Error GoTo 0
        If obj_App Is Nothing Then
            Set obj_App = CreateObject("PowerPoint.Application")
        End If

        On Error Resume Next
        Set obj_File = obj_App.ActivePresentation
        On Error GoTo 0
        If obj_File Is Nothing Then
            Set obj_File = obj_App.Presentations.Add
        End If
        Dim pptLayout As Object
        Set pptLayout = obj_File.SlideMaster.CustomLayouts.Item(7)
        obj_App.Visible = True
        Set obj_Target = obj_File.Slides.AddSlide(obj_File.Slides.Count + 1, pptLayout)
        Set oSAlayout = obj_App.SmartArtLayouts("urn:microsoft.com/office/officeart/2005/8/layout/orgChart1")
        Set obj_Shape = obj_Target.Shapes.AddSmartArt(oSAlayout)
End Select


    Set oshp = obj_Shape.SmartArt
    obj_Shape.Height = 600
       
    'By default, SMartart is added with some nodes. Remove them initially
    For i = 1 To 5
        oshp.AllNodes(1).Delete
    Next i
    
    'Add Project Summay Task as root node
    Set MyRootNode = oshp.AllNodes.Add
    With MyRootNode
        Set MyRootNode = NodeContent(MyRootNode, P.ProjectSummaryTask)
        'Project Summary Task as bold
        .TextFrame2.TextRange.Font.Bold = True
    End With

    'Outlinelevel 1 as "msoSmartArtNodeBelow" to get them in the second row
    For Each T In P.Tasks
        If Not T Is Nothing Then
            If T.OutlineLevel = 1 Then
                Set MyParentNode = AddMyNode(MyRootNode, True, T)
            End If
        End If
    Next T


Application.Visible = True
Application.ScreenUpdating = True
Application.StatusBar = False
On Error GoTo 0

MsgBox "Done"
obj_App.Visible = True
Exit Sub
LastError:

obj_File.ScreenUpdating = True
obj_File.Visible = True
Application.Visible = True
Application.ScreenUpdating = True
Application.StatusBar = False
        MsgBox "Error:" & vbNewLine _
        & Err.Number & " - " & Err.Description _
        & vbCritical + vbOKOnly
        Exit Sub

End Sub



Function AddMyNode(ByVal RootNode As SmartArtNode, ByVal NewNodeFlag As Boolean, ByVal T As Task) As SmartArtNode
'***********************************************************************************
'Code is provided “AS IS” without warranty of any kind, either expressed or implied,
'including but not limited to the implied warranties of merchantability and/or
'fitness for a particular purpose.
'***********************************************************************************

Dim cT           As Task    'child tasks
Dim sProj        As Project 'potential inserted project
Dim MyParentNode As SmartArtNode

Set MyParentNode = RootNode

'Use Flag1 to decide if task is to be exported
If T.Flag1 = c_TaskExportValue Then
    If NewNodeFlag Then
        Set AddMyNode = RootNode.AddNode(msoSmartArtNodeBelow)
    Else
        Set AddMyNode = RootNode.AddNode(msoSmartArtNodeAfter, msOrgChartLayoutBothHanging)
    End If

    AddMyNode.OrgChartLayout = msoOrgChartLayoutRightHanging

    If T.Summary Then Set MyParentNode = AddMyNode
    With AddMyNode
        Set AddMyNode = NodeContent(AddMyNode, T)
    End With

    If T.Summary Then
        If T.Subproject <> "" Then
            FileOpen Name:=T.Subproject, ReadOnly:=True
            Set sProj = ActiveProject
            Set T = sProj.ProjectSummaryTask
        End If
        For Each cT In T.OutlineChildren
            If cT.Flag1 = c_TaskExportValue Then
                Set AddMyNode = AddMyNode(MyParentNode, True, cT)
            End If
        Next cT
        If Not sProj Is Nothing Then
            FileClose pjDoNotSave
        End If
    End If
End If
End Function

Function NodeContent(ByVal CurrentNode As SmartArtNode, ByVal T As Task) As SmartArtNode
    With CurrentNode
  
        .TextFrame2.TextRange.ParagraphFormat.SpaceAfter = 1
        'Add required fields from task and format text
        'Use date format as defined in Project using Application.DefaultDateformat
        'or set Dateformat as listed in https://docs.microsoft.com/de-de/office/vba/api/project.pjdateformat
        .TextFrame2.TextRange.Text = T.OutlineNumber _
                                    & vbTab _
                                    & T.PercentComplete & " %" _
                                    & vbCrLf _
                                    & T.Name _
                                    & vbCrLf _
                                    & DateFormat(T.Start, Application.DefaultDateFormat) _
                                    & vbTab _
                                    & DateFormat(T.Finish, Application.DefaultDateFormat)
        .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = vbBlack
        .TextFrame2.TextRange.Font.Size = 5

        With .Shapes
            .ShapeStyle = msoShapeStylePreset1
            .Line.ForeColor.RGB = 0 'vbBlack not working in Word
            With .Item(1).Fill
                .Transparency = 0.5
                .TwoColorGradient msoGradientDiagonalUp, 1
                'https://msdn.microsoft.com/en-us/library/system.drawing.color.getbrightness(v=vs.110).aspx
                .GradientStops.Item(2).Color.Brightness = 1
                'https://msdn.microsoft.com/de-de/library/microsoft.office.interop.excel.colorformat.tintandshade%28v=office.15%29.aspx
                .GradientStops.Item(2).Color.TintAndShade = 0.5
                'set color depending on progress
                .GradientStops.Item(1).Position = (100 - T.PercentComplete) / 100
                .GradientStops.Item(2).Position = 1
                .GradientStops.Item(1).Transparency = 0
                .GradientStops.Item(2).Transparency = 0.7
                .GradientStops.Item(1).Color = vbWhite
                .GradientStops.Item(2).Color = vbBlack
                .GradientStops.Item(1).Color.Brightness = 0
                .GradientStops.Item(2).Color.Brightness = 0.8
            End With
        End With
    End With
    Set NodeContent = CurrentNode
End Function

Categories: Project, VBA

Source: https://atwork.blog/post/2019/05/19/Project-Export-PSP-in-Office-Export-WBS-to-Office