Rename Selected Shapes

If i select 2 or more shapes & then run a micro.Rename all shapes name to user input name. code is that but it is not working

Sub RenameShape()

Dim objName

Dim sr As ShapeRange

Dim s3 As Shape

Set sr = ActiveSelectionRange

If sr.Shapes.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

Set s3 = ActiveDocument.Selection.Name = objName

End If

Exit Sub

End Sub

  • You need to loop each shape in your shape range:

    Sub RenameShape() Dim objName As String Dim sr As ShapeRange Dim s As Shape Set sr = ActiveSelectionRange If sr.Shapes.Count = 0 Then MsgBox "You need to select a shape first" Exit Sub End If For Each s In sr.Shapes objName = s.Name objName = InputBox$("Assing a new name to this shape", "Rename Shape", objName) If objName <> "" Then s.Name = objName End If Next s End Sub