TPE

Tavvafi@gmail.com

≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡

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