Consulting

Results 1 to 13 of 13

Thread: Freeform poly and nodes

  1. #1
    VBAX Expert TrippyTom's Avatar
    Joined
    Jul 2005
    Location
    New York, NY (USA)
    Posts
    556
    Location

    Freeform poly and nodes

    Is there a way (in vba) to add nodes to a shape after it's created? Or do I have to add them in sequence as I'm creating the shape?

    My situation:
    I want to add 3 nodes to a simple rectangle to allow for multiple connector lines to snap to the shape. PowerPoint won't let me edit points on a rectangle, so what I did was convert it to a freeform poly in the same size so I could add nodes to it.

    But then I ran into this problem. How do I add nodes after-the-fact?
    Office 2010, Windows 7
    goal: to learn the most efficient way

  2. #2
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    You should be able to add nodes using insert nodes method

    example from vb help


    With myDocument.Shapes(3).Nodes
        .Insert 4, msoSegmentCurve, msoEditingSmooth, 210, 100
    End With
    Last edited by Aussiebear; 04-28-2023 at 02:36 AM. Reason: Adjusted the code tags
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  3. #3
    VBAX Expert TrippyTom's Avatar
    Joined
    Jul 2005
    Location
    New York, NY (USA)
    Posts
    556
    Location
    Hi John,

    Yeah, i saw that in the help files too, but my problem was figuring out the correct formula to get it to work with user-input values. I will post my solution when I get time to sterilize the macro form company info.

    Thanks for the help.
    Office 2010, Windows 7
    goal: to learn the most efficient way

  4. #4
    VBAX Expert TrippyTom's Avatar
    Joined
    Jul 2005
    Location
    New York, NY (USA)
    Posts
    556
    Location
    Ok, here's the macro I came up with. Hope this helps someone out there.
    Office 2010, Windows 7
    goal: to learn the most efficient way

  5. #5
    VBAX Expert TrippyTom's Avatar
    Joined
    Jul 2005
    Location
    New York, NY (USA)
    Posts
    556
    Location
    Why I made this macro:
    I needed a better way to create more advanced Org Charts instead of using the "Insert Diagram" feature in PowerPoint. Unfortunately, autoshape rectangles won't allow you to right click and "edit points" for some crazy reason. You have to use a free-form polygon instead.

    How it works:
    This macro converts a regular rectangle into a freeform poly, then adds the specified number of nodes on the specified edges and distributes them evenly. This helps me save time by not having to create "helper objects" behind other rectangles to connect lines to.
    Office 2010, Windows 7
    goal: to learn the most efficient way

  6. #6
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    Nice macro!

    Did you consider adding a text box (based on the size and position of the freeform) and then group it?
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  7. #7
    VBAX Expert TrippyTom's Avatar
    Joined
    Jul 2005
    Location
    New York, NY (USA)
    Posts
    556
    Location
    Thanks John,

    Yeah I thought about that, and I don't think it would be too difficult. You could store whatever text was in the original shape into a variable and put that into a text box on top, then group it. After all, it's all about making your macros easier on the user. Good idea.

    I just wanted to get the functionality down correctly before I moved on.
    Office 2010, Windows 7
    goal: to learn the most efficient way

  8. #8
    VBAX Expert TrippyTom's Avatar
    Joined
    Jul 2005
    Location
    New York, NY (USA)
    Posts
    556
    Location
    Hey John (and anyone else),

    I tried to add your idea about adding a textbox, and I've almost got it, but it seems to be ignoring some of the settings I try to apply to the textbox:
    1) It's not turning off the autosize
    2) It's not vertically aligning to middle

    The following is my code on the OK button:
    Private Sub btn_OK_Click()
    'Created by Tom Tripp
    On Error Resume Next
    Dim oWidth As Single
    Dim oHeight As Single
    Dim oLeft As Single
    Dim oTop As Single
    Dim oResult As Single
    Dim s As Shape
    Dim i As Long
    Dim mySlide As Long
    Dim units As Long
    Dim tempText As String
    units = 72
    mySlide = ActiveWindow.View.Slide.SlideIndex
    frm_Subdivide.Hide
    For Each s In Application.ActiveWindow.Selection.ShapeRange
        If s.AutoShapeType = msoShapeRectangle Then
            'if shape has text, put it in variable
            If s.HasTextFrame Then
                tempText = s.TextFrame.TextRange.Text
            End If
            'get size (width, height) and position (top, left)
            oWidth = s.Width
            oHeight = s.Height
            oLeft = s.Left
            oTop = s.Top
            'MsgBox ("Width=" & oWidth & vbCr & "Height=" & oHeight & vbCr & "Left=" & oLeft & vbCr & "Top=" & oTop)
            's.Delete 'delete original shape since you can't add nodes on a rectangle autoshape
            'plot new rect in same spot with freeform polygon
            Set mydocument = ActivePresentation.Slides(mySlide)
            With mydocument.Shapes.BuildFreeform(msoEditingCorner, X1:=oLeft, Y1:=oTop)
                .AddNodes SegmentType:=msoSegmentLine, EditingType:=msoEditingAuto, X1:=(oLeft + oWidth), Y1:=oTop
               .AddNodes SegmentType:=msoSegmentLine, EditingType:=msoEditingAuto, X1:=(oLeft + oWidth), Y1:=(oTop + oHeight)
               .AddNodes SegmentType:=msoSegmentLine, EditingType:=msoEditingAuto, X1:=oLeft, Y1:=(oTop + oHeight)
               .AddNodes SegmentType:=msoSegmentLine, EditingType:=msoEditingAuto, X1:=oLeft, Y1:=oTop
               .ConvertToShape.Select
               Set myshape = Application.ActiveWindow.Selection.ShapeRange
               myshape.Name = "ffShape"
               With myshape.Nodes
                   'Top Nodes
                   oResult = ((oLeft + oWidth) - oLeft) / (tb_nodesTop + 1)
                   For i = 1 To tb_nodesTop
                       .Insert i, msoSegmentLine, msoEditingAuto, X1:=(oLeft + (oResult * i)), Y1:=(oTop)
                   Next I
                   'Right Nodes
                   oResult = ((oTop + oHeight) - oTop) / (tb_nodesRight + 1)
                   For i = 1 To tb_nodesRight
                       .Insert (i + tb_nodesTop + 1), msoSegmentLine, msoEditingAuto, X1:=(oLeft + oWidth), Y1:=(oTop + (oResult * i))
                   Next I
                   'Bottom Nodes
                   oResult = ((oLeft + oWidth) - oLeft) / (tb_nodesBottom + 1)
                   Set myshape = Application.ActiveWindow.Selection.ShapeRange
                   For i = 1 To tb_nodesBottom
                       .Insert (i + tb_nodesTop + tb_nodesRight + 2), msoSegmentLine, msoEditingAuto, X1:=(oLeft + (oResult * i)), Y1:=(oTop + oHeight)
                   Next I
                   'Left Nodes
                   oResult = ((oTop + oHeight) - oTop) / (tb_nodesLeft + 1)
                   For i = 1 To tb_nodesLeft
                       .Insert (i + tb_nodesTop + tb_nodesRight + tb_nodesBottom + 3), msoSegmentLine, msoEditingAuto, X1:=oLeft, Y1:=(oTop + (oResult * i))
                   Next I
            End With
            'If there was text in the shape, add a new textbox with that text on top of the new shape
            If tempText <> "" Then
                Set myText = ActivePresentation.Slides(mySlide).Shapes.AddTextbox(msoTextOrientationHorizontal, oLeft, oTop, oWidth, oHeight)
                myText.Name = "ffText"
                myText.TextFrame.TextRange.Text = tempText
                .TextFrame.AutoSize = ppAutoSizeNone
                .TextFrame.VerticalAnchor = msoAnchorMiddle
                With ActiveWindow.Selection
                    .TextRange.ParagraphFormat.Alignment = ppAlignCenter
                    '.ShapeRange.Fill.Transparency = 0#
                    With .ShapeRange.TextFrame
                        .WordWrap = msoTrue
                        .TextRange.Font.Name = "Arial"
                        .TextRange.Font.Size = 8
                        .AutoSize = ppAutoSizeNone
                        .VerticalAnchor = msoAnchorMiddle
                        .HorizontalAnchor = msoAnchorNone
                        .TextRange.ParagraphFormat.Alignment = ppAlignCenter
                        .TextRange.ParagraphFormat.WordWrap = msoTrue
                    End With
                    'Group the Shape and Text
                    .SlideRange.Shapes.Range(Array("ffShape", "ffText")).Group
                End With
            End If
        End With
        s.Delete
    Else
        MsgBox ("Your selection either isn't a rectangle or it's already converted into a freeform polygon." & _
        vbCr & "Please select a normal autoshape rectangle to convert.")
    End If
    Next s
    Call resetSubdivForm
    End Sub
    Last edited by Aussiebear; 04-28-2023 at 02:44 AM. Reason: Adjusted the code tags
    Office 2010, Windows 7
    goal: to learn the most efficient way

  9. #9
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    Only got time for a quick look see if this points you in the right direction

    I think that you may hit problems using the same name each time. This doesnt error here (2007) but I think it will in 2003 when two shapes on the slide have the same name. Also it may confuse the group if you run it twice.
    Private Sub btn_OK_Click()
         'Created by Tom Tripp
        On Error Resume Next
        Dim oWidth As Single
        Dim oHeight As Single
        Dim oLeft As Single
        Dim oTop As Single
        Dim oResult As Single
        Dim s As Shape
        Dim i As Long
        Dim mySlide As Long
        Dim units As Long
        Dim tempText As String
        units = 72
        mySlide = ActiveWindow.View.Slide.SlideIndex
        frm_Subdivide.Hide
    For Each s In Application.ActiveWindow.Selection.ShapeRange
        If s.AutoShapeType = msoShapeRectangle Then
            'if shape has text, put it in variable
            If s.HasTextFrame Then
                tempText = s.TextFrame.TextRange.Text
            End If
            'get size (width, height) and position (top, left)
            oWidth = s.Width
            oHeight = s.Height
            oLeft = s.Left
            oTop = s.Top
            'MsgBox ("Width=" & oWidth & vbCr & "Height=" & oHeight & vbCr & "Left=" & oLeft & vbCr & "Top=" & oTop)
            's.Delete 'delete original shape since you can't add nodes on a rectangle autoshape
            'plot new rect in same spot with freeform polygon
            Set mydocument = ActivePresentation.Slides(mySlide)
            With mydocument.Shapes.BuildFreeform(msoEditingCorner, X1:=oLeft, Y1:=oTop)
                .AddNodes SegmentType:=msoSegmentLine, EditingType:=msoEditingAuto, X1:=(oLeft + oWidth), Y1:=oTop
                .AddNodes SegmentType:=msoSegmentLine, EditingType:=msoEditingAuto, X1:=(oLeft + oWidth), Y1:=(oTop + oHeight)
                .AddNodes SegmentType:=msoSegmentLine, EditingType:=msoEditingAuto, X1:=oLeft, Y1:=(oTop + oHeight)
                .AddNodes SegmentType:=msoSegmentLine, EditingType:=msoEditingAuto, X1:=oLeft, Y1:=oTop
                .ConvertToShape.Select
                Set myshape = Application.ActiveWindow.Selection.ShapeRange
                myshape.Name = "ffShape"
                With myshape.Nodes
                    'Top Nodes
                    oResult = ((oLeft + oWidth) - oLeft) / (tb_nodesTop + 1)
                    For i = 1 To tb_nodesTop
                        .Insert i, msoSegmentLine, msoEditingAuto, X1:=(oLeft + (oResult * i)), Y1:=(oTop)
                    Next I
                    'Right Nodes
                    oResult = ((oTop + oHeight) - oTop) / (tb_nodesRight + 1)
                    For i = 1 To tb_nodesRight
                        .Insert (i + tb_nodesTop + 1), msoSegmentLine, msoEditingAuto, X1:=(oLeft + oWidth), Y1:=(oTop + (oResult * i))
                    Next I
                    'Bottom Nodes
                    oResult = ((oLeft + oWidth) - oLeft) / (tb_nodesBottom + 1)
                    Set myshape = Application.ActiveWindow.Selection.ShapeRange
                    For i = 1 To tb_nodesBottom
                        .Insert (i + tb_nodesTop + tb_nodesRight + 2), msoSegmentLine, msoEditingAuto, X1:=(oLeft + (oResult * i)), Y1:=(oTop + oHeight)
                    Next I
                    'Left Nodes
                    oResult = ((oTop + oHeight) - oTop) / (tb_nodesLeft + 1)
                    For i = 1 To tb_nodesLeft
                        .Insert (i + tb_nodesTop + tb_nodesRight + tb_nodesBottom + 3), msoSegmentLine, msoEditingAuto, X1:=oLeft, Y1:=(oTop + (oResult * i))
                    Next I
                End With
                'If there was text in the shape, add a new textbox with that text on top of the new shape
                If tempText <> "" Then
                    'text box needs to be a little smaller than the shape I think
                    Set mytext = ActivePresentation.Slides(mySlide).Shapes.AddTextbox(msoTextOrientationHorizontal, oLeft + 10, oTop + 10, oWidth - 20, oHeight - 20)
                    With mytext
                        .Name = "ffText"
                        .TextFrame.TextRange.Text = tempText
                        .TextFrame.AutoSize = ppAutoSizeNone
                        .TextFrame.VerticalAnchor = msoAnchorMiddle
                        .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
                        .TextFrame.TextRange.ParagraphFormat.WordWrap = True
                        .Height = oHeight - 20 'don't know why this is needed!
                    End With
                    ' With ActiveWindow.Selection
                    ' .TextRange.ParagraphFormat.Alignment = ppAlignCenter
                    ' .ShapeRange.Fill.Transparency = 0#
                    ' With .ShapeRange.TextFrame
                         ' .WordWrap = msoTrue
                         ' .TextRange.Font.Name = "Arial"
                         ' .TextRange.Font.Size = 8
                         ' .AutoSize = ppAutoSizeNone
                         ' .VerticalAnchor = msoAnchorMiddle
                         ' .HorizontalAnchor = msoAnchorNone
                         ' .TextRange.ParagraphFormat.Alignment = ppAlignCenter
                         ' .TextRange.ParagraphFormat.WordWrap = msoTrue
                    ' End With
                ' End With
            End If
        End With 'Group the Shape and Text
        ActivePresentation.Slides(mySlide).Shapes.Range(Array("ffShape", "ffText")).Group
        s.Delete
            Else
        MsgBox ("Your selection either isn't a rectangle or it's already converted into a freeform polygon." & _
        vbCr & "Please select a normal autoshape rectangle to convert.")
            End If
        Next s
        Call resetSubdivForm
    End Sub
    Last edited by Aussiebear; 04-28-2023 at 03:01 AM. Reason: Adjusted the code tags
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  10. #10
    VBAX Expert TrippyTom's Avatar
    Joined
    Jul 2005
    Location
    New York, NY (USA)
    Posts
    556
    Location
    The reason I thought I had to adjust the height was because the textbox was interfering with my ability to connect points on the shape behind it.
    Is there a way to avoid that without changing the textbox size so the shape encompasses it?

    And how did you get the middle-align working?
    Office 2010, Windows 7
    goal: to learn the most efficient way

  11. #11
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    "I dont know why this is needed"

    I meant it seems to be needed otherwise the text box doesn't resize properly even though I think it should as the height is already specified. Your right - the text box has to be a little smaller than the shape hence the +10 and -20
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  12. #12
    VBAX Expert TrippyTom's Avatar
    Joined
    Jul 2005
    Location
    New York, NY (USA)
    Posts
    556
    Location
    Hi John,

    I decided to take out the naming part and leave them ungrouped because of what you mentioned with doing it more than once. I would have to put it in a for/next loop and use an iterative variable with the name to make it unique and I guess I'm too lazy to figure that out.

    It works great as it is. Thanks for all your help.
    Office 2010, Windows 7
    goal: to learn the most efficient way

  13. #13
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    If I ever get time I'll take a look again and see if I can add to it. I guess a lot of people reading won't realise how useful this would be in creating custom org charts so I'll take this opportunity to mention it!!
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •