How to weld all shapes in shaperange into one

Hello,
Please 
Here is my macro.
Enjoi!

Sub BhBp_Weld()
Dim OrigSelection As ShapeRange
Set OrigSelection = ActiveSelectionRange
If OrigSelection.Shapes.Count > 0 Then
Dim BhBp_objects() As Shape
ReDim BhBp_objects(1 To OrigSelection.Shapes.Count)

Dim X As Integer

For X = 1 To OrigSelection.Shapes.Count
' Create a unique variable name for each shape
Set BhBp_objects(X) = OrigSelection.Shapes(X)
Next X

' Now you can access the shapes using the BhBp_objects array
For X = 1 To UBound(BhBp_objects) 'LBound
Set BhBp_objects(1) = BhBp_objects(1).Weld(BhBp_objects(X), False, False)
Next X
Else
MsgBox "No Shapes selected"
End If
End Sub

Greetings!