PowerPoint VBA Recognizing Shapes in a Grouping

864 Views Asked by At

I am trying to create a simple PowerPoint file to capture a series of milestones for a project portfolio. I have created the following Macro to create the milestone visual and group the shapes. However, I am looking to create another macro for updating/statusing the milestone. Specifically, I want the user to select the group and then run a macro to that will allow the user to update the date and move the shapes accordingly or, if the task is complete, fill in the shape.

I struggle with the initiation of the update macro to identify the shapes and its' content to complete the calculation. For example, I don't know how to read in the date in to move the milestone left/right based on the new date. Any help is appreciated!

Code:

Private Sub EnterTask_Click()

Dim Sld As Slide
Dim shapeMile As Shape
Dim shapeTask As Shape
Dim shapeECD As Shape
Dim dateECD As String
Dim taskText As String

Dim StatusBox As Shape

dateECD = "6/12/18"
taskText = "Task #1"

Set Sld = Application.ActiveWindow.View.Slide

With Sld

'Create shape with Specified Dimensions and Slide Position
Set shapeMile = Sld.Shapes.AddShape(Type:=msoShapeIsoscelesTriangle, _
    Left:=25, Top:=150, Width:=15, Height:=15)

    With shapeMile
        .Rotation = 180
        .Tags.Add "Milestone", "Bug"
        .Line.Visible = msoTrue
        .Fill.Visible = msoFalse
        .Shadow.Visible = msoFalse

    End With

Set shapeECD = Sld.Shapes.AddTextbox(msoTextOrientationHorizontal, _
    Left:=8, Top:=165, Width:=50, Height:=30)

    With shapeECD
        .Tags.Add "Milestone", "ECD"
        .Line.Visible = msoFalse
        .Fill.Visible = msoFalse
        .Shadow.Visible = msoFalse
        .TextFrame.TextRange.Characters.Text = dateECD
        .TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter
        .TextFrame.VerticalAnchor = msoAnchorTop
        .TextFrame.HorizontalAnchor = msoAnchorCenter
        .TextFrame.TextRange.Font.Size = 8
        .TextFrame.TextRange.Font.Name = "Arial"
        .TextFrame.TextRange.Font.Italic = msoFalse
        .TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
    End With

Set shapeTask = Sld.Shapes.AddTextbox(msoTextOrientationHorizontal, _
    Left:=8, Top:=135, Width:=50, Height:=30)

    With shapeTask
        .Tags.Add "Milestone", "Task"
        .Line.Visible = msoFalse
        .Fill.Visible = msoFalse
        .Shadow.Visible = msoFalse
        .TextFrame.TextRange.Characters.Text = taskText
        .TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter
        .TextFrame.VerticalAnchor = msoAnchorTop
        .TextFrame.HorizontalAnchor = msoAnchorCenter
        .TextFrame.TextRange.Font.Size = 8
        .TextFrame.TextRange.Font.Name = "Arial"
        .TextFrame.TextRange.Font.Italic = msoFalse
        .TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
    End With

.Shapes.Range(Array(shapeMile.Name, shapeECD.Name, shapeTask.Name)).Group

End With

End Sub
0

There are 0 best solutions below