Sub Test() Dim s As Shape Set s = ActiveShape If s Is Nothing Then MsgBox "Nothing is selected." Else s.Next(cdrLevelLayer, True, True).CreateSelection End IfEnd Sub