Breaking text apart

Function BreakText(TextShape As Shape) As ShapeRange
Dim sr As ShapeRange, n As TreeNode, LastShape As Shape
    Set n = TextShape.TreeNode.Previous
    Set sr = TextShape.BreakApartEx
    If n Is Nothing Then
        Set LastShape = sr(1).Layer.Shapes.First
    Else
        Set LastShape = n.Shape.Next
    End If
    While sr.LastShape.StaticID <> LastShape.StaticID
        sr.Add sr.LastShape.Previous
    Wend
    Set BreakText = sr
End Function

Private Sub TestBreakText()
Dim s As Shape, sr As ShapeRange
    Set s = ActiveShape
    Set sr = BreakText(s)
    For Each s In sr
        Debug.Print s.Text.Story.Text
    Next
End Sub