Project: Export PSP in Office / Export WBS to Office

PrivateSub Project_Open(ByVal pj As Project)Call EnableReferencesEndSub

'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

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