Freeform poly and nodes

[John Wilson]

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