Quantcast
Channel: blog.atwork.at
Viewing all articles
Browse latest Browse all 1118

Project: Export PSP in Office / Export WBS to Office

0
0
  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

PrivateSub Project_Open(ByVal pj As Project)Call EnableReferencesEndSub

Code: Referenzen aktivieren / Enable References

'Constants and VariablesGlobalConst c_Office = "{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}"GlobalConst c_Excel = "{00020813-0000-0000-C000-000000000046}"GlobalConst c_Word = "{00020905-0000-0000-C000-000000000046}"GlobalConst 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 omittedDim strGUID AsVariantDim theRefs AsVariantDim theRef AsVariantDim i AsLong'*****************************************************************************'**** Set references for SmartArt, Excel, Word and Powerpoint'*****************************************************************************Set theRefs = Application.VBE.VBProjects(1).ReferencesWith theRefs'****Remove broken referencesFor i = theRefs.Count To 1 Step -1Set theRef = .Item(i)If theRef.isbroken = TrueThen
                .References.Remove theRefEndIfNext i'****Errors have to be omitted in this caseOnErrorResumeNext'Office
        .AddFromGuid Guid:=c_Office, major:=1, Minor:=0'Application.VBE.ActiveVBProject.References.AddFromGuid Guid:=c_Office, major:=1, Minor:=0'Evaluate errorSelectCase Err.NumberCase 32813'Reference already set, no action requiredCase vbNullString'Reference successfully setCaseElse'Error while setting reference - exit subGoTo Ref_ErrorEndSelect'Excel
        .AddFromGuid Guid:=c_Excel, major:=1, Minor:=0'Evaluate errorSelectCase Err.NumberCase 32813'Reference already set, no action requiredCase vbNullString'Reference successfully setCaseElse'Error while setting reference - exit subGoTo Ref_ErrorEndSelect'Word
        .AddFromGuid Guid:=c_Word, major:=1, Minor:=0'Fehler interpretierenSelectCase Err.NumberCase 32813'Referenz schon gesetzt - keine Aktivität erforderlichCase vbNullString'Referenz ohne Problem gesetztCaseElse'Unbekannter Fehler - AbbruchGoTo Ref_ErrorEndSelect'PowerPoint
        .AddFromGuid Guid:=c_PowerPoint, major:=1, Minor:=0'Evaluate errorSelectCase Err.NumberCase 32813'Reference already set, no action requiredCase vbNullString'Reference successfully setCaseElse'Error while setting reference - exit subGoTo Ref_ErrorEndSelectEndWith'****Re-enable errorsOnErrorGoTo 0ExitSub
    Ref_Error:
            MsgBox "There was an issue activating"& vbNewLine _& "a required reference."& vbNewLine _& "Macro ended!", vbCritical + vbOKOnly, "Error!"ExitSub
    End Sub

Code: Export PSP / Export WBS

GlobalConst c_TaskExportValue = True'Define if Flag1 has to be true or false to be exportedSub 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         AsObjectDim obj_File        AsObjectDim obj_Target      AsObjectDim oSAlayout       As Office.SmartArtLayoutDim obj_Shape       AsObjectDim oshp            As SmartArtDim v_App           AsStringDim P               As ProjectDim 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")SelectCase v_AppCase""
        MsgBox "No application selected. Macro will be terminated"ExitSub
    Case "1"
        v_App = "Word"Case"2"
        v_App = "Excel"Case"3"
        v_App = "PowerPoint"CaseElse
        MsgBox "Invalid input. Macro will be terminated"ExitSub
End SelectSet P = ActiveProjectOnErrorResumeNextSelectCase v_AppCase"Excel"Set obj_App = GetObject(, "Excel.Application")OnErrorGoTo 0If obj_App IsNothingThenSet obj_App = CreateObject("Excel.Application")EndIf
        obj_App.Visible = TrueOnErrorResumeNextSet obj_File = obj_App.ActiveWorkbookOnErrorGoTo 0If obj_File IsNothingThenSet obj_File = obj_App.Workbooks.Add'New workbook, we can use default sheetSet obj_Target = obj_File.ActiveSheetElse'Existing workbook, get a new sheet to avoid overwriteSet obj_Target = obj_File.Sheets.AddEndIfSet 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")OnErrorGoTo 0If obj_App IsNothingThenSet obj_App = CreateObject("Word.Application")EndIf
        obj_App.Visible = TrueOnErrorResumeNextSet obj_File = obj_App.ActiveDocumentOnErrorGoTo 0If obj_File IsNothingThenSet obj_File = obj_App.Documents.AddEndIf'Get end of documentSet obj_Target = obj_File.Range(obj_File.Range.End - 1, obj_File.Range.End)'add a new line in document
        obj_Target = vbCrLfSet 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")OnErrorGoTo 0If obj_App IsNothingThenSet obj_App = CreateObject("PowerPoint.Application")EndIfOnErrorResumeNextSet obj_File = obj_App.ActivePresentationOnErrorGoTo 0If obj_File IsNothingThenSet obj_File = obj_App.Presentations.AddEndIfDim pptLayout AsObjectSet pptLayout = obj_File.SlideMaster.CustomLayouts.Item(7)
        obj_App.Visible = TrueSet 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)EndSelectSet oshp = obj_Shape.SmartArt
    obj_Shape.Height = 600'By default, SMartart is added with some nodes. Remove them initiallyFor i = 1 To 5
        oshp.AllNodes(1).DeleteNext i'Add Project Summay Task as root nodeSet MyRootNode = oshp.AllNodes.AddWith MyRootNodeSet MyRootNode = NodeContent(MyRootNode, P.ProjectSummaryTask)'Project Summary Task as bold
        .TextFrame2.TextRange.Font.Bold = TrueEndWith'Outlinelevel 1 as "msoSmartArtNodeBelow" to get them in the second rowForEach T In P.TasksIfNot T IsNothingThenIf T.OutlineLevel = 1 ThenSet MyParentNode = AddMyNode(MyRootNode, True, T)EndIfEndIfNext T


Application.Visible = True
Application.ScreenUpdating = True
Application.StatusBar = FalseOnErrorGoTo 0

MsgBox "Done"
obj_App.Visible = TrueExitSub
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 + vbOKOnlyExitSub

End Sub



Function AddMyNode(ByVal RootNode As SmartArtNode, ByVal NewNodeFlag AsBoolean, 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 tasksDim sProj        As Project 'potential inserted projectDim MyParentNode As SmartArtNodeSet MyParentNode = RootNode'Use Flag1 to decide if task is to be exportedIf T.Flag1 = c_TaskExportValue ThenIf NewNodeFlag ThenSet AddMyNode = RootNode.AddNode(msoSmartArtNodeBelow)ElseSet AddMyNode = RootNode.AddNode(msoSmartArtNodeAfter, msOrgChartLayoutBothHanging)EndIf

    AddMyNode.OrgChartLayout = msoOrgChartLayoutRightHanging

    If T.Summary ThenSet MyParentNode = AddMyNodeWith AddMyNodeSet AddMyNode = NodeContent(AddMyNode, T)EndWithIf T.Summary ThenIf T.Subproject <> ""Then
            FileOpen Name:=T.Subproject, ReadOnly:=TrueSet sProj = ActiveProjectSet T = sProj.ProjectSummaryTaskEndIfForEach cT In T.OutlineChildrenIf cT.Flag1 = c_TaskExportValue ThenSet AddMyNode = AddMyNode(MyParentNode, True, cT)EndIfNext cTIfNot sProj IsNothingThen
            FileClose pjDoNotSaveEndIfEndIfEndIfEndFunctionFunction NodeContent(ByVal CurrentNode As SmartArtNode, ByVal T As Task) As SmartArtNodeWith 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 = 5With .Shapes
            .ShapeStyle = msoShapeStylePreset1
            .Line.ForeColor.RGB = 0 'vbBlack not working in WordWith .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.8EndWithEndWithEndWithSet NodeContent = CurrentNodeEndFunction

Viewing all articles
Browse latest Browse all 1118

Latest Images

Trending Articles