Problem

PowerPoint acts weird and causes code to break if multiple shapes on a slide have the same name.

PowerPoint doesn't allow us to give two shapes on a slide the same name.

But PowerPoint itself CREATES multiple same-named shapes on a slide when a user duplicates shapes.

Point 2 shows wit. Point 3 shows a total lack of wit. On average, then, PowerPoint is a half-wit.

If you're running into problems because of multiple same-named shapes, the code below is a bit of self defense you can use. It uniquely renames each shape on each slide, so no two shapes have the same name.

Ideally, we'd do this in a way that's reversible, but of course that's not possible. PowerPoint has created a situation that it will not allow us to create, so we can't go back.

So we'll at least preserve the original names in a way that lets us extract them later if need be.

We also need to make sure that if we run this thing multiple times, we limit the amount of extra data that gets tacked onto the end of shape names. This is especially important because:

WARNING: In PowerPoint 2003 and prior, shape names can't be over 32 characters long. That limit's been raised to 254 characters in PowerPoint 2007 and later. The code below will cause no problems with PowerPoint's default shape names, but it doesn't try to protect against errors caused by shapes that have already been renamed by some other process. We'll leave that as an exercise for the reader.

NOTE: If we simply append a character or characters to a shape's name, PowerPoint 2003 and previous ignore us without throwing an error. It simply doesn't change the shape name. If we append a space and THEN the additional character(s), PowerPoint behaves. This bug has been fixed in PowerPoint 2007 and later. The code below takes account of this bug by adding the needed space, and will work in any version of PowerPoint.

Solution

Make the presentation you want to fix the active presentation, then run this code.

Sub RenameAllShapes()
' Renames all shapes in a presentation to prevent problems with
' duplicate shape names
Dim oSl As Slide
Dim osh As Shape
Dim sTemp As String
Dim lCtr As Long
Dim sFlagString As String
Dim sAddMe As String
' The strategy is:
' Create a flag string ... this'll be a rotating selection of one of three
' strings, !RnmA, !RnmB or !RnmC
' The previously-used flag is stored in a presentation level tag
' Get the previously-used flag, choose a new flag based on the result:
sFlagString = ActivePresentation.Tags("RenameAllShapes")
Select Case UCase(sFlagString)
Case Is = ""
sFlagString = "!RnmA"
Case Is = "!RNMA"
sFlagString = "!RnmB"
Case Is = "!RNMB"
sFlagString = "!RnmC"
Case Is = "!RNMC"
sFlagString = "!RnmA"
Case Else
sFlagString = "!RnmA"
End Select
Debug.Print sFlagString
' save the new flag back to the presentation tag
ActivePresentation.Tags.Add "RenameAllShapes", sFlagString
' look at each shape on each slide
lCtr = 1
For Each oSl In ActivePresentation.Slides
For Each osh In oSl.Shapes
' create a unique string to add to the end of the name
' Looks like !RnmA-xxxxx where xxxxx is a unique sequential number
' derived from the lCtr counter
' MUST always be the same number of digits so we can strip it later
' allowing for 10,000 shapes should do it
sAddMe = " " & sFlagString & "-" & Format(lCtr, "00000")
' has the shape already been renamed? if so, extract original name
If InStr(osh.Name, "!Rnm") > 0 Then
sTemp = Left$(osh.Name, Len(osh.Name) - Len(sAddMe))
' or just use the name as it is
Else
sTemp = osh.Name
End If
' tack the AddMe string onto the end of the shape name
sTemp = sTemp & sAddMe
osh.Name = sTemp
lCtr = lCtr + 1
Next
Next
End Sub

Did this solve your problem? If so, please consider supporting the PPT FAQ with a small PayPal donation.