Uniquely rename all shapes in a presentation, eliminate duplicate shape names
- 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.
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