DRAw bounding box around each object

How can I modify this code where I only want each shape with a bounding box drawing around them?

Here is an example Shelby made (modified?) below showing a feature where each line of text has a bounding box.

Sub TextRectangles()
    Dim s As Shape
    Dim srSelection As ShapeRange
    Dim srStateBefore As ShapeRange
    Dim srStateAfter As ShapeRange
    Dim srDuplicateText As ShapeRange
    Dim x As Double, y As Double, w As Double, h As Double
    
    Set srSelection = ActiveSelectionRange 'Get the current selection
    
    ' Get all the text objects before the operation
    Set srStateBefore = ActivePage.FindShapes(Type:=cdrTextShape)
    
    'Duplicate each text shape that is more than one line
    For Each s In srSelection
        If s.Type = cdrTextShape Then
            If s.Text.Story.Lines.Count > 1 Then s.Duplicate.BreakApart
        End If
    Next s
    
    ' And now after the operation
    Set srStateAfter = ActivePage.FindShapes(Type:=cdrTextShape)
    
    ' Any new objects are the ones created by the BreakApart calls
    ' Remove all the "old" objects
    srStateAfter.RemoveRange srStateBefore
    Set srDuplicateText = srStateAfter.ReverseRange
    srDuplicateText.ConvertToCurves 'So we can create tight fitting rectangles

    For Each s In srDuplicateText
        s.GetBoundingBox x, y, w, h
        ActiveLayer.CreateRectangle2 x, y, w, h
    Next s
    
    srDuplicateText.Delete 'Delete our duplicates
    srSelection.CreateSelection 'Set the selection back to the orginal
    
    Set srStateBefore = Nothing
    Set srStateAfter = Nothing
    Set srDuplicateText = Nothing
End Sub

see my image example.