Building complex shapes using the freeFormBuilder

[rdekanter]

Hello,

First post here, so apologies if it is too detailed!

I have created a set of icons using PowerPoint shapes and rather than have them as a collection in a reference file I am looking to see if I can reconstruct them programmatically so that I could create a customised Ribbon Gallery. As an example, consider the following shape which is constructed simply by using the "Union" function of a three quarter pie shape and a quarter pie shape. It is made up of 8 nodes.

2201722018

To try and do this, I have looked at exporting the existing nodes and their properties with the following code:



Sub GetPoints()

Dim sh As Shape
Dim nd As ShapeNode
Dim xy As Variant
Dim nodemsg As String
Dim Seg As String
Dim Edit As String

Set sh = ActiveWindow.Selection.ShapeRange(1)

For Each nd In sh.Nodes
xy = nd.Points

Select Case nd.SegmentType
Case 1: Seg = "msoSegmentCurve"
Case 0: Seg = "msoSegmentLine"

End Select
Select Case nd.EditingType
Case 0: Edit = "msoEditingAuto"
Case 1: Edit = "msoEditingCorner"
Case 2: Edit = "msoEditingSmooth"
Case 3: Edit = "msoEditingSymmetric"
End Select

nodemsg = nodemsg & ".AddNodes " & Seg & ", " & Edit & ", " & xy(1, 1) & ", " & xy(1, 2) & vbCrLf
Next

Debug.Print nodemsg

End Sub


From this I can tell that there are in fact 17 nodes, which after some digging is because it includes the "handles" of each point as additional nodes as well. If I try to then reconstruct a shape using freeform builder and the output of the first code I get this:

22019



Sub construct()

Dim freeFormBuilder As freeFormBuilder
Dim mySlide As Slide
Dim myShape As Shape

Set mySlide = ActivePresentation.Slides(ActiveWindow.View.Slide.SlideIndex)
Set freeFormBuilder = mySlide.Shapes.BuildFreeform(msoEditingCorner, 139.9373, 280.6482) 'uses the output for the 1st node

With freeFormBuilder
.AddNodes msoSegmentLine, msoEditingCorner, 245.2909, 280.6482 'uses the output for the 2nd node onwards
.AddNodes msoSegmentCurve, msoEditingCorner, 245.2909, 338.8334
.AddNodes msoSegmentCurve, msoEditingCorner, 198.1225, 386.0018
.AddNodes msoSegmentCurve, msoEditingCorner, 139.9373, 386.0018
.AddNodes msoSegmentCurve, msoEditingAuto, 125.4049, 160.7621
.AddNodes msoSegmentCurve, msoEditingCorner, 183.5902, 160.7621
.AddNodes msoSegmentCurve, msoEditingCorner, 230.7586, 207.9306
.AddNodes msoSegmentCurve, msoEditingCorner, 230.7586, 266.1158
.AddNodes msoSegmentLine, msoEditingAuto, 125.4049, 266.1158
.AddNodes msoSegmentLine, msoEditingCorner, 125.4049, 371.4695
.AddNodes msoSegmentCurve, msoEditingAuto, 67.21969, 371.4695
.AddNodes msoSegmentCurve, msoEditingAuto, 20.05126, 324.301
.AddNodes msoSegmentCurve, msoEditingAuto, 20.05126, 266.1158
.AddNodes msoSegmentCurve, msoEditingAuto, 20.05126, 207.9306
.AddNodes msoSegmentCurve, msoEditingAuto, 67.21969, 160.7621
.AddNodes msoSegmentCurve, msoEditingAuto, 125.4049, 160.7621
.AddNodes msoSegmentLine, msoEditingAuto, 139.9373, 280.6482 'Repeats the output for the first node to close off the freeform
End With

Set myShape = freeFormBuilder.ConvertToShape

End Sub


With a bit of trial and error I was able to use the co-ordinates to create a replica shape, however there are two issues with this approach in that
a) it's not automatic and I have a lot of icons, some of which are much more complicated
b) When applying an outline to the original icon, it applies two outlines, one to each part of the shape. With my newly built one it also has a line connecting the two segments which I don't want

22020



Sub construct2()

Dim freeFormBuilder As freeFormBuilder
Dim mySlide As Slide
Dim myShape As Shape

Set mySlide = ActivePresentation.Slides(ActiveWindow.View.Slide.SlideIndex)
Set freeFormBuilder = mySlide.Shapes.BuildFreeform(msoEditingCorner, 139.9373, 280.6482)

With freeFormBuilder
.AddNodes msoSegmentLine, msoEditingCorner, 245.2909, 280.6482
.AddNodes msoSegmentCurve, msoEditingCorner, 245.2909, 338.8334, 198.1225, 386.0018, 139.9373, 386.0018
.AddNodes msoSegmentCurve, msoEditingCorner, 139.9373, 280.6482
.AddNodes msoSegmentLine, msoEditingCorner, 125.4049, 160.7621
.AddNodes msoSegmentCurve, msoEditingCorner, 183.5902, 160.7621, 230.7586, 207.9306, 230.7586, 266.1158
.AddNodes msoSegmentCurve, msoEditingCorner, 125.4049, 266.1158
.AddNodes msoSegmentCurve, msoEditingCorner, 125.4049, 371.4695
.AddNodes msoSegmentCurve, msoEditingCorner, 67.21969, 371.4695, 20.05126, 324.301, 20.05126, 266.1158
.AddNodes msoSegmentCurve, msoEditingCorner, 20.05126, 207.9306, 67.21969, 160.7621, 125.4049, 160.7621
.AddNodes msoSegmentLine, msoEditingCorner, 139.9373, 280.6482
End With

Set myShape = freeFormBuilder.ConvertToShape

End Sub


Would anyone be able to help me figure this out as I've been stuck on it for ages? The best solution would be one that takes a selected shape, reads its node properties, then creates an identical new shape next to it.

Thanks in advance for any help

[rdekanter]

I realise you're not supposed to bump threads, but given it's been a couple of months I figure it's worth a try before I give up on this problem...

Thanks in advance if anyone does have any ideas

[Paul_Hossler]

Well ...

you could

1. manually create the shapes you want (formatting, grouping, etc.)

2. put them on a hidden slide or slides

3. give each a meaningful name

4. then have the macro copy the shape and insert it

[rdekanter]

Thanks for the suggestion Paul,

unfortunately I can't do this as I am trying to make it part of an Add In file so that once installed a user will always have access to the functions whenever PowerPoint is open and without having to go searching for files. As far as I can tell, you cannot reference a slide in an Add In because PowerPoint strips all slides when it creates the add in.

EDIT:
I tried locating a separate file, opening it, copying a relevant shape, closing the file and then pasting it. Seems to be acceptably quick so I should be able to make this work as a companion file

[John Wilson]

As Paul suggests we always use a reference file open it with no window copy the correct shape and close it again. If you install the Add from an msi you can also create the reference file in a hidden location.

[rdekanter]

Code snippet in case any one is interested



'Create new PowerPoint object and open Icon Set fileSet pPowerPoint = New PowerPoint.Application
Set SourcePPT = pPowerPoint.Presentations.Open(SourcePPTPath)


'Copy icon and close source file
SourcePPT.Slides(1).Shapes(selectedID).Copy
SourcePPT.Close
Set SourcePPT = Nothing


'Paste shape on current slide
With ActiveWindow
.View.Paste
.Selection.ShapeRange.Left = 100
.Selection.ShapeRange.Top = 100
End With