Uniquely rename all shapes in a presentation, eliminate duplicate shape names

Problem

1. PowerPoint acts weird and causes code to break if multiple shapes on a slide have the same name.
2. PowerPoint doesn't allow us to give two shapes on a slide the same name.
3. But PowerPoint itself CREATES multiple same-named shapes on a slide when a user duplicates shapes.
4. 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

---