blog.atwork.at

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

'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
    

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