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