Printable View
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?
You should be able to add nodes using insert nodes method
example from vb help
Code:With myDocument.Shapes(3).Nodes
.Insert 4, msoSegmentCurve, msoEditingSmooth, 210, 100
End With
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.
Ok, here's the macro I came up with. Hope this helps someone out there.
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.
Nice macro!
Did you consider adding a text box (based on the size and position of the freeform) and then group it?
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. :)
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:
Code: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
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.
Code: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
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? :)
"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
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. :)
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!!