block shadow is not removing, please kindly correct

Sub ClearEffects_ActiveSelection2()
If ActiveSelectionRange Is Nothing Then Exit Sub

Dim Shape As Shape
Dim Shapes As ShapeRange
Dim i As Long

Set Shapes = ActiveSelectionRange.Shapes.FindShapes(Query:="@com.Effects.Count > 0")

For Each Shape In Shapes
For i = 1 To Shape.Effects.Count
Shape.Effects(i).Clear
Next i

Shape.CustomCommand "BlockShadow", "ClearBlockShadow"
Next
End Sub