Rename more then one shape

Question

I have macro for renaming shape but it only works for one shape object. I want to create macro to rename all selected shapes OR would be perfect if I can select one multiple shapes, run macro and InputBox comes back to me for each shape and rename it. Is this possible to create? Could anybody help me? Thanks in advance

Sub RenameShape()
    Dim objName

    On Error GoTo CheckErrors

    If ActiveWindow.Selection.ShapeRange.Count = 0 Then
        MsgBox "You need to select a shape first"
        Exit Sub
    End If
    objName = ActiveWindow.Selection.ShapeRange(1).Name
    objName = InputBox$("Assing a new name to this shape", "Rename Shape", objName)

    If objName <> "" Then
        ActiveWindow.Selection.ShapeRange(1).Name = objName
    End If

    Exit Sub

    CheckErrors:
        MsgBox Err.Description

End Sub

Answer 1

Add a loop to process each shape:

Sub RenameShape()

    ' it's best to dim variables as specific types:
    Dim objName As String
    Dim oSh As Shape

    On Error GoTo CheckErrors

    With ActiveWindow.Selection.ShapeRange
        If .Count = 0 Then
            MsgBox "You need to select a shape first"
            Exit Sub
        End If
    End With

    For Each oSh In ActiveWindow.Selection.ShapeRange

        objName = oSh.Name
        objName = InputBox$("Assign a new name to this shape", "Rename Shape", objName)
        ' give the user a way out
        If objName = "QUIT" Then
            Exit Sub
        End If

        If objName <> "" Then
            oSh.Name = objName
        End If
    Next

    Exit Sub

CheckErrors:
        MsgBox Err.Description

End Sub