- Deutsch
- English
- Code: Referenzen beim Öffnen aktivieren / Enable References on Open
- Code: Referenzen aktivieren / Enable References
- 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.
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.
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.
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.
Nach Start des Makros für Word ergibt sich folgendes Bild:
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.
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.
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.
Running this macro for Word will provide the following:
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
Source: https://blog.atwork.at/post/Project-Export-PSP-in-Office-Export-WBS-to-Office