Quick and easy way to removes empty lines of text

[runflacruiser]

Hi.
I wrote this a little while ago.
I noticedd even artistic text of 2 lines has the possibility of having more empty lines.
Is there a better or faster way to remove any empty lines in an artistic text string.

PS. Is this a bug that artic teext can have these empty lines?

-John

Option Explicit

Sub align()

Dim s As Shape, p As Page, sr As ShapeRange
Dim i As Integer, j As Integer
Dim shNewText As Shape, strNew As String
Dim x As Double, y As Double, w As Double, h As Double
ActiveDocument.ReferencePoint = cdrBottomLeft

For Each p In ActiveDocument.Pages
    p.Activate
    Set s = ActivePage.Shapes.FindShape(, cdrTextShape) 'wasn't at first but npw locking and crashing here.
    If s.Text.Type = cdrParagraphText Then
            s.GetBoundingBox x, y, w, h
            s.Text.ConvertToArtistic
            For i = s.Text.Story.Lines.count To 1 Step -1
                If Len(s.Text.Story.Lines(i + 1).Characters.All) < 2 _
                Or s.Text.Story.Lines(i + 1).Characters.All = " " Then
                    Dim strTemp As String
                    strTemp = s.Text.Story.Lines(i).Characters.All
                    If strTemp = "" Then
                        strTemp = strTemp & " "

                    End If
                    s.Text.Story.Lines(i).Characters.All = VBA.Left(strTemp, Len(strTemp) - 1)
            End If
        Next i
        s.Text.ConvertToParagraph
        s.Text.Frame.VerticalAlignment = cdrBottomJustify
        s.SetSize w, h
        s.SetPosition x, y

    End If

Next p

End Sub