Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!
Manipulating individual shapes within grouped shapes in PowerPoint using VBA?
I began by asking about VBA in PowerPoint to recolor certain parts of a bitmap (see previous question here), but Jamie Garroch suggested a much better approach, using a vector image which can be manipulated more easily.
My code below imports an EMF file, converts it to MS drawing object, then locates a particular shape within the group so I can recolor it. Any suggestions to make this more efficient, since I may need to recolor dozens of icons across multiple slides in a deck? Thanks!
My code below imports an EMF file, converts it to MS drawing object, then locates a particular shape within the group so I can recolor it. Any suggestions to make this more efficient, since I may need to recolor dozens of icons across multiple slides in a deck? Thanks!
Sub recolorswoosh()
Dim x As Integer
Dim iconpicked As String
Dim myshape As Shape
Dim currentslide As Slide
Dim refindleft As Single
Dim refindtop As Single
Dim myMSshape As Shape
Dim farthestleft As Single
Dim myswoosh As Shape
iconpicked = "C:\Test\nuclear.emf"
Set currentslide = ActivePresentation.Slides(ActiveWindow.View.Slide.SlideIndex)
Set myshape = currentslide.Shapes.AddPicture(FileName:=iconpicked, linktofile:=msoFalse, _
savewithdocument:=msoTrue, Left:=200, Top:=200)
findleft = myshape.Left 'store left edge of imported EMF so we can refind it later
findtop = myshape.Top 'store top edge of imported EMF so we can refind it later
myshape.Ungroup 'convert EMF to Microsoft Office drawing object so we can manipulate it
'find the converted shape by matching stored coordinates
For Each myshape In currentslide.Shapes
If myshape.Left = findleft And myshape.Top = findtop Then
Set myMSshape = myshape
Exit For
End If
Next
'the left most shape will be the swoosh in every case. Iterate the shapes to identify it.
farthestleft = 1200
For x = 1 To myMSshape.GroupItems.count
Set myshape = myMSshape.GroupItems(x)
If myshape.Left < farthestleft Then
Set myswoosh = myshape
farthestleft = myshape.Left
End If
Next x
MsgBox "The swoosh is named " & myswoosh.Name & vbCrLf & " located at left = " & myswoosh.Left & vbCrLf & " filled with color " & myswoosh.Fill.ForeColor
myswoosh.Fill.ForeColor.RGB = RGB(255, 0, 0)
End Sub
Do more with
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
I've made a whole bunch of suggestions in the overly-commented code below:
And here it is all tidied up:
' Always put this line at the top of every module as it'll really help you debug projects
Option Explicit
Sub recolorswoosh()
Dim x As Long ' was Integer but object collections use Long
Dim iconpicked As String
Dim myshape As Shape
'Dim currentslide As Slide no longer needed
'Dim refindleft As Single no longer needed
'Dim refindtop As Single no longer needed
Dim myMSshape As Shape
'Dim farthestleft As Single no longer needed
Dim myswoosh As Shape
' These were undefined (found by using Option Explicit) but are no longer needed
' Dim findleft As Single, findtop As Single
iconpicked = "C:\Test\nuclear.emf"
'Set currentslide = ActivePresentation.Slides(ActiveWindow.View.Slide.SlideIndex)
'Set myshape = currentslide.Shapes.AddPicture(FileName:=iconpicked, linktofile:=msoFalse, _
savewithdocument:=msoTrue, Left:=200, Top:=200)
' Above can be simplified to:
Set myshape = ActiveWindow.View.Slide.Shapes.AddPicture(FileName:=iconpicked, linktofile:=msoFalse, _
savewithdocument:=msoTrue, Left:=200, Top:=200)
' No longer needed:
'findleft = myshape.Left 'store left edge of imported EMF so we can refind it later
'findtop = myshape.Top 'store top edge of imported EMF so we can refind it later
'find the converted shape by matching stored coordinates
'For Each myshape In currentslide.Shapes
' If myshape.Left = findleft And myshape.Top = findtop Then
' Set myMSshape = myshape
' Exit For
' End If
'Next
' The above part can be simplified by creating a reference to the MS drawing group at the time it's converted from EMF
Set myMSshape = myshape.Ungroup(1) 'convert EMF to Microsoft Office drawing object so we can manipulate it
'the left most shape will be the swoosh in every case. Iterate the shapes to identify it.
'farthestleft = ActivePresentation.PageSetup.SlideWidth ' was 1200 but not sure why?
'For x = 1 To myMSshape.GroupItems.Count
' Set myshape = myMSshape.GroupItems(x)
' If myshape.Left < farthestleft Then
' Set myswoosh = myshape
' farthestleft = myshape.Left
' End If
'Next x
' The above part could be simplified to find the swoosh using its layer,
' which is also constant at 2, above the AutoShapeXX object.
Set myswoosh = myMSshape.GroupItems(2)
' You could optionally delete the AutoShapeXX object which is always created
' as an invisble boundary shape in the lowest layer when ungrouping an EMF.
myMSshape.GroupItems(1).Delete
' You could optionally name the group and items in it to help identification
' in the Selection Pane for a user.
With myMSshape
x = InStrRev(iconpicked, "\")
.Name = "Icon : " & Mid(iconpicked, x + 1, Len(iconpicked) - x)
.GroupItems(1).Name = "swoosh"
For x = 2 To .GroupItems.Count: .GroupItems(x).Name = "icon element": Next
End With
MsgBox "The swoosh is named " & myswoosh.Name & vbCrLf & " located at left = " & myswoosh.Left & vbCrLf & " filled with color " & myswoosh.Fill.ForeColor
' Recolour to theme to be on brand
myswoosh.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent1
End Sub
And here it is all tidied up:
Option Explicit
Sub recolorswoosh2()
Dim x As Long
Dim iconpicked As String
Dim myshape As Shape, myMSshape As Shape, myswoosh As Shape
iconpicked = "C:\Test\nuclear.emf"
iconpicked = myPath & "\nuclear.emf"
' insert the EMF picture from the file system
Set myshape = ActiveWindow.View.Slide.Shapes.AddPicture(iconpicked, msoFalse, msoTrue, 200, 200)
' create a reference to the MS drawing group at the time it's converted from EMF
Set myMSshape = myshape.Ungroup(1)
' find the swoosh using its layer which is constant at 2
Set myswoosh = myMSshape.GroupItems(2)
' delete the AutoShapeXX object
myMSshape.GroupItems(1).Delete
' name the group and items in it
With myMSshape
x = InStrRev(iconpicked, "\")
.Name = "Icon : " & Mid(iconpicked, x + 1, Len(iconpicked) - x)
.GroupItems(1).Name = "swoosh"
For x = 2 To .GroupItems.Count: .GroupItems(x).Name = "icon element": Next
End With
' Recolour to theme to be on brand
myswoosh.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent1
End Sub
And as you may want to process multiple shapes, you need to change the declaration of the above sub and call it from a second procedure like this:
You'll need to work out how to identify the icons, perhaps by name, safer is to use .Tags which are not editable via the PowerPoint UI by a user and can be added to a shape at the point it's inserted programmatically.
Sub recolorswoosh2(oShp As Shape)
...
End Sub
Sub RecolorIcons()
Dim oSld As Slide
Dim oShp As Shape
For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
'If oShp meets criteria xyz then
' recolorswoosh2 oShp
'End If
Next
End If
End Sub
You'll need to work out how to identify the icons, perhaps by name, safer is to use .Tags which are not editable via the PowerPoint UI by a user and can be added to a shape at the point it's inserted programmatically.
Thanks, Jamie. This is much slicker.
The reason for my convoluted method of locating the swoosh (left-most shape) within the group was that I'll be dealing with a library of several hundred of these icons. How can we be certain the swoosh will always be GroupItem(2)? Is there some instruction about ordering the shapes that I need to give to my design group as they create these in AI, to assure this is consistent?
I notice the AutoShapeXX that shows up when I ungroup the EMF. Seems to be some sort of extra container. I like the idea of deleting it, but is there a particular advantage other than keeping things tidy? Again, are we certain it will always be GroupItem(1)?
Finally, I was planning to name the shapes when imported but will go with your suggestion to use tags so the code can find them for future recoloring.
Thanks!
The reason for my convoluted method of locating the swoosh (left-most shape) within the group was that I'll be dealing with a library of several hundred of these icons. How can we be certain the swoosh will always be GroupItem(2)? Is there some instruction about ordering the shapes that I need to give to my design group as they create these in AI, to assure this is consistent?
I notice the AutoShapeXX that shows up when I ungroup the EMF. Seems to be some sort of extra container. I like the idea of deleting it, but is there a particular advantage other than keeping things tidy? Again, are we certain it will always be GroupItem(1)?
Finally, I was planning to name the shapes when imported but will go with your suggestion to use tags so the code can find them for future recoloring.
Thanks!
oops - I left one line of test code in my tidied up routine. This should be deleted: (if a moderator is reading, please could you delete it from the line 9 in the second code block of post ID: 42043209?)
Regarding group item 2. Whenever a WMF (or EPS) file is ungrouped the first time, it's converted to the native MSO vector format, as a group of shapes. The element order of the original WMF vector graphic will be retained so I assumed (maybe wrongly) that your design team will ensure that the swoosh will always be the element in the backmost layer. It's on layer 2 because the ungroup-to-convert process creates an unwanted shapes named AutoShape XX in the backmost layer of the group. This shape (which is equal in size to the boundary of all other shapes in the group) isn't normally needed and hence can be deleted. It's useful in my vicons product because all icons must occupy the same square area to retain their family look and feel so resizing them based on the invisible AutoShape is useful when the icon is not square.
When I coded this add-in I relied on these EPS to MSO conversion behaviours and it didn't fail in this respect for the 660 icons, each of various numbers of layers.
iconpicked = myPath & "\nuclear.emf"
Regarding group item 2. Whenever a WMF (or EPS) file is ungrouped the first time, it's converted to the native MSO vector format, as a group of shapes. The element order of the original WMF vector graphic will be retained so I assumed (maybe wrongly) that your design team will ensure that the swoosh will always be the element in the backmost layer. It's on layer 2 because the ungroup-to-convert process creates an unwanted shapes named AutoShape XX in the backmost layer of the group. This shape (which is equal in size to the boundary of all other shapes in the group) isn't normally needed and hence can be deleted. It's useful in my vicons product because all icons must occupy the same square area to retain their family look and feel so resizing them based on the invisible AutoShape is useful when the icon is not square.
When I coded this add-in I relied on these EPS to MSO conversion behaviours and it didn't fail in this respect for the 660 icons, each of various numbers of layers.
Thanks for the explanation. I do believe the swoosh will always be the backmost layer, but I was worried that more complex icons might have an inconsistent number of icon elements on top of that. I'll experiment to be sure.
Could I piggyback one more related question? If there happens to be an unfilled picture placeholder on the slide at the time I insert the icon using the above method, it sticks the icon into that placeholder, and then you can't ungroup it so the rest of the code fails. That's an annoying default PowerPoint behavior as far as I've been able to tell, to stick an inserted picture into the next empty placeholder. How do I avoid this and place my inserted icon on the slide rather than into the placeholder? Thanks.
Could I piggyback one more related question? If there happens to be an unfilled picture placeholder on the slide at the time I insert the icon using the above method, it sticks the icon into that placeholder, and then you can't ungroup it so the rest of the code fails. That's an annoying default PowerPoint behavior as far as I've been able to tell, to stick an inserted picture into the next empty placeholder. How do I avoid this and place my inserted icon on the slide rather than into the placeholder? Thanks.
It doesn't matter how many objects will be on top because PowerPoint indexes from the back to the front so the backmost layer is always index 1 (or 2) if you keep the AutoShape.
Regarding the placeholder thing, yes, I came across that when developing another add-in. I can't recall what I did so let me go dig around in some code...
Regarding the placeholder thing, yes, I came across that when developing another add-in. I can't recall what I did so let me go dig around in some code...
Given hiding the placeholders doesn't help (PowerPoint makes the first empty one visible again and inserts the picture), the easiest way I can think of is to create a temporary slide without picture-compatible placeholders, insert the EMF there, copy it to the clipboard, delete the temporary slide and then paste it to the original target slide.
Note too that there is a big assumption with any code that uses ActivePresentation or ActiveView and that's that the presentation is (a) editable, not read only or in protected view and (b) that the view is of a slide and not the Notes pane, Thumbnails pane, Master view, the annoying "cursor in-between slide thumbnails state" etc. etc.
But that's a whole different topic!
Sub recolorswoosh3()
Dim x As Long
Dim iconpicked As String
Dim myshape As Shape, myMSshape As Shape, myswoosh As Shape
Dim curSlide As Long
iconpicked = "C:\Test\nuclear.emf"
curSlide = ActiveWindow.View.Slide.SlideIndex
With ActivePresentation.Slides
' add a new slide without picture palceholders
With .AddSlide(curSlide + 1, ActivePresentation.SlideMaster.CustomLayouts(1))
' insert the EMF picture from the file system, copy it to the clipboard and then delete it
With .Shapes.AddPicture(iconpicked, msoFalse, msoTrue, 200, 200)
.Copy
.Delete
End With
' delete the temporary slide and paste the EMF to the original target slide
.Delete
Set myshape = ActivePresentation.Slides(curSlide).Shapes.Paste(1)
End With
End With
' create a reference to the MS drawing group at the time it's converted from EMF
Set myMSshape = myshape.Ungroup(1)
' find the swoosh using its layer which is constant at 2
Set myswoosh = myMSshape.GroupItems(2)
' delete the AutoShapeXX object
myMSshape.GroupItems(1).Delete
' name the group and items in it
With myMSshape
x = InStrRev(iconpicked, "\")
.Name = "Icon : " & Mid(iconpicked, x + 1, Len(iconpicked) - x)
.GroupItems(1).Name = "swoosh"
For x = 2 To .GroupItems.Count: .GroupItems(x).Name = "icon element": Next
End With
' Recolour to theme to be on brand
myswoosh.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent1
End Sub
Note too that there is a big assumption with any code that uses ActivePresentation or ActiveView and that's that the presentation is (a) editable, not read only or in protected view and (b) that the view is of a slide and not the Notes pane, Thumbnails pane, Master view, the annoying "cursor in-between slide thumbnails state" etc. etc.
But that's a whole different topic!
Thanks for all the help! I've had to resort to this kind of workaround before. We may be able to train users, but I'll use this if I have to. I'm good with those assumptions since my toolbar is being used when they are actively editing the presentation. I have a subroutine I call at the top of almost every procedure to deal with the in between slides issue and make sure one slide is selected, so no worries there.
Premium Content
You need an Expert Office subscription to comment.Start Free Trial