Tidying Up Paragraphs

[HTSCF Fareha]

I'm trying to tidy up all paragraphs for a number of Content Controls within the same document. The idea is to remove any blank paragraphs at the start and end of each whilst ensuring single paragraph spacing in between each paragraph. This should also tidy up and ensure single word spacing.

So far I have the following which is working with the exception of not removing empty paragraphs at the start. No matter what I try I just cannot get them removed, there is always a double return.

Content.jpg



As this is going to be used a number of times, I will place in its own sub and call as required after setting the range.

Option Explicit

Sub CreateDoc()
    Dim oDoc   As Document
    Dim oRng   As Range
    Dim oRngPara As Range
    Dim oParagraphCount As Long
    Dim x      As Integer
    Dim intCounter As Integer
    Dim oCtrl  As control
    Dim oCC    As ContentControl
    Dim oFrmTriageRC As frmTriageRC

    If ActiveDocument = ThisDocument Then
        MsgBox "You cannot use this function to edit the document template", vbCritical
        Exit Sub
    End If
    
    Set oDoc = ActiveDocument
    Set oFrmTriageRC = New frmTriageRC
    With oFrmTriageRC
        
        For Each oCC In oDoc.ContentControls
            If oCC.ShowingPlaceholderText = False Then
                Select Case oCC.Title
                    Case "Summary"
                        .txtSummary.Text = oCC.Range.Text
                    Case "Research"
                        .txtResearch.Text = oCC.Range.Text        
                End Select
            End If
        Next oCC
        
        .Show
        If .Tag = 0 Then GoTo lbl_Exit
        
        For Each oCC In oDoc.ContentControls
            
            On Error Resume Next
            
            Select Case oCC.Title
                    
                Case "Summary"
                    oRng.Text = .txtSummary.Text
                    
                    Application.ScreenUpdating = False
                    
                    ' Ensure there is only single spacing between words
                    With oRng.Find
                        .ClearFormatting
                        .Replacement.ClearFormatting
                        'Here is where it is actually looking for spaces between words
                        .Text = " [ ]@([! ]@[? ])"
                        'This line tells it to replace the excessive spaces with one space
                        .Replacement.Text = " \1"
                        .MatchWildcards = True
                        .Wrap = wdFindStop
                        .Format = False
                        .Forward = True
                        .Execute Replace:=wdReplaceAll
                    End With
                    
                    On Error Resume Next
                    
                    ' Ensure there is only single paragraph spacing
                    oParagraphCount = oDoc.Paragraphs.Count
                    
                    'Loop Through Each Paragraph (in reverse order)
                    For x = oParagraphCount To 1 Step -1
                        If x - 1 > 1 Then
                            If oRng.Paragraphs(x).Range.Text = vbCr And oRng.Paragraphs(x - 1).Range.Text = vbCr Then
                                oRng.Paragraphs(x).Range.Delete
                            End If
                        End If
                    Next x
                    
                    ' Ensure empty first paragraphs are removed
                    intCounter = 1
                    Do
                        Set oRngPara = oRng.Paragraphs(1).Range
                        If oRngPara.Text = vbCr Then oRngPara.Delete
                        
                        intCounter = intCounter + 1
                    Loop Until intCounter >= 5
                    
                    ' Ensure empty last paragraphs are removed 
                    intCounter = 1
                    Do
                        Set oRngPara = oRng.Paragraphs.Last.Range
                        If oRngPara.Text = vbCr Then oRngPara.Delete
                        
                        intCounter = intCounter + 1
                    Loop Until intCounter >= 5
                    
                    ' Convert to sentence case
                    oRng.Case = wdTitleSentence
                    
                    Application.ScreenUpdating = True
                        
              Case "Research"
                
                oRng.Text = .txtResearch.Text
                
                Application.ScreenUpdating = False
                    
                    ' Ensure there is only single spacing between words
                    With oRng.Find
                        .ClearFormatting
                        .Replacement.ClearFormatting
                        'Here is where it is actually looking for spaces between words
                        .Text = " [ ]@([! ]@[? ])"
                        'This line tells it to replace the excessive spaces with one space
                        .Replacement.Text = " \1"
                        .MatchWildcards = True
                        .Wrap = wdFindStop
                        .Format = False
                        .Forward = True
                        .Execute Replace:=wdReplaceAll
                    End With
                    
                    On Error Resume Next
                    
                    ' Ensure there is only single paragraph spacing
                    oParagraphCount = oDoc.Paragraphs.Count
                    
                    'Loop Through Each Paragraph (in reverse order)
                    For x = oParagraphCount To 1 Step -1
                        If x - 1 > 1 Then
                            If oRng.Paragraphs(x).Range.Text = vbCr And oRng.Paragraphs(x - 1).Range.Text = vbCr Then
                                oRng.Paragraphs(x).Range.Delete
                            End If
                        End If
                    Next x
                    
                    ' Ensure empty first paragraphs are removed
                    
                    intCounter = 1
                    Do
                        Set oRngPara = oRng.Paragraphs(1).Range
                        If oRngPara.Text = vbCr Then oRngPara.Delete
                        
                        intCounter = intCounter + 1
                    Loop Until intCounter >= 5
                    
                    ' Ensure empty last paragraphs are removed
                    
                    intCounter = 1
                    Do
                        Set oRngPara = oRng.Paragraphs.Last.Range
                        If oRngPara.Text = vbCr Then oRngPara.Delete
                        
                        intCounter = intCounter + 1
                    Loop Until intCounter >= 5
                    
                    ' Convert to sentence case
                    oRng.Case = wdTitleSentence
                    
            End Select
        Next oCC
    End With
    
lbl_Exit:
    Unload oFrmTriageRC
    Set oFrmTriageRC = Nothing
    Set oRng = Nothing
    Set oCC = Nothing
    Set oDoc = Nothing
    Exit Sub
End Sub

[gmayor]

That looks a bit over the top. Try the following instead

Dim oCC As ContentControl
Dim oPara As Paragraph
Dim lPara As Long
    For Each oCC In ActiveDocument.ContentControls
        If oCC.Type = wdContentControlRichText Then
            oCC.LockContentControl = False
            For lPara = oCC.Range.Paragraphs.Count To 1 Step -1
                Set oPara = oCC.Range.Paragraphs(lPara)
                If Len(oPara.Range.Text) = 1 Then oPara.Range.Delete
            Next lPara
            oCC.Range.ParagraphFormat.SpaceAfter = 6
            oCC.Range.Find.Execute findText:="[ ]{1,}", _
                                   MatchWildcards:=True, _
                                   Replacewith:=" ", _
                                   Replace:=wdReplaceAll, _
                                   Wrap:=wdFindStop
            oCC.Range.Case = wdTitleSentence
            oCC.LockContentControl = True
        End If
    Next oCC

[HTSCF Fareha]

Thanks for looking at this for me Graham.

I agree that my version was rather over engineered. I've tweaked it slightly so that I can apply it to certain specified ranges, but unfortunately it is now putting a double paragraph at the end.

Dim oCC        As ContentControl
Dim oRng       As Range
Dim oPara      As Paragraph
Dim lPara      As Long

For Each oCC In oDoc.ContentControls
    If oCC.ShowingPlaceholderText = False Then
        Select Case oCC.Title
            Case "Summary"
                .txtSummary.Text = oCC.Range.Text
        End Select
    End If
Next oCC

For Each oCC In oDoc.ContentControls
    
    Select Case oCC.Title
        
        Case "Summary"
            oRng.Text = .txtSummary.Text
    End Select
End If
Next oCC


With oRng.ContentControls
    If oCC.Type = wdContentControlRichText Then
        oCC.LockContentControl = False
        For lPara = oCC.Range.Paragraphs.Count To 1 Step -1
            Set oPara = oCC.Range.Paragraphs(lPara)
            If Len(oPara.Range.Text) = 1 Then oPara.Range.Delete
        Next lPara
        oCC.Range.ParagraphFormat.SpaceAfter = 12
        oCC.Range.Find.Execute findText:="[ ]{1,}", _
                               MatchWildcards:=True, _
                               Replacewith:=" ", _
                               Replace:=wdReplaceAll, _
                               Wrap:=wdFindStop
        oCC.Range.Case = wdTitleSentence
        oCC.LockContentControl = True
    End If
End With

End Select
Next oCC
End With

[gmayor]

You seem to have created a host of unnecessary loops?
Try the following

For Each oCC In ActiveDocument.ContentControls
        Select Case oCC.Title
            Case "Summary"
                oCC.LockContentControl = False
                oCC.Range.Text = .txtSummary.Text
                For lPara = oCC.Range.Paragraphs.Count To 1 Step -1
                    Set oPara = oCC.Range.Paragraphs(lPara)
                    If Len(oPara.Range.Text) = 1 Then oPara.Range.Delete
                Next lPara
                oCC.Range.ParagraphFormat.SpaceAfter = 6
                oCC.Range.Find.Execute findText:="[ ]{1,}", _
                                       MatchWildcards:=True, _
                                       Replacewith:=" ", _
                                       Replace:=wdReplaceAll, _
                                       Wrap:=wdFindStop
                oCC.Range.Case = wdTitleSentence
                oCC.LockContentControl = True
        End Select
    Next oCC

[HTSCF Fareha]

Sorry Graham, but it still isn't playing ball.

I've attached the form as I cannot fathom why it isn't working.

[gmayor]

I've made a few changes to remove a lot of duplication. It appears to work as intended.
Watch the order in which you apply processes to the text, so that subsequent processes do not change what has already been applied.

[HTSCF Fareha]

Thanks again Graham!

Alas, firstly when entering a hyphenated lastname in aggrieved or suspect, it deletes the firstname altogether, but works correctly if no hyphenation is input.

Secondly, that pesky one extra carriage return still appears.

[gmayor]

The first issue relates to the TrueTitleCase function and the additional line issue relates to the way that text boxes handle line breaks, fixed in the userform code.

[HTSCF Fareha]

Many thanks Graham!

I've been looking at the adjustments that you made to try and see what is happening.

The hyphen part I think I have fathomed out and I reckon the IsHyphenated function is creating a variable of sName and then using this by counting back two words to then create the range to be converted to uppercase.

Annoyingly I cannot see on the UserForm how the change to the 'cmdExecute' combats the extra line break issue.

If Asc(Right(txtEnquiries.Text, 1)) = 10 Then
        txtEnquiries.Text = Left(txtEnquiries.Text, Len(txtEnquiries.Text) - 2)
    End If

[HTSCF Fareha]

Finally fathomed it out and cannot believe that I didn't work out that this was looking for the linefeed (ascii 10) character.

[HTSCF Fareha]

I knew that it was too good to be true. This works brilliantly on a word document, but once I have produced my document, it then needs to be copied and pasted into a bespoke programme that is RTF. It would appear that it doesn't recognise the "spaceafter" so ignores this and places everything one line after the next with no spaces.

[gmayor]

In that case you need to re-introduce an additional paragraph break after each paragraph before copying and pasting to the RTF application. Maybe something like

Sub CopyCC()
Dim oCC As ContentControl
Dim oRng As Range
Dim oPara As Paragraph
Dim i As Long
Dim lCount As Long
    On Error Resume Next
    Set oCC = Selection.Range.ParentContentControl
    Set oRng = oCC.Range
    If oRng.Paragraphs.Count > 1 Then
        lCount = oRng.Paragraphs.Count - 1
        For i = lCount To 1 Step -1
            oRng.Paragraphs(i).Range.InsertParagraphAfter
        Next i
        oRng.Copy
        For i = lCount * 2 To 1 Step -1
            If i Mod 2 = 0 Then
                oRng.Paragraphs(i).Range.Delete
            End If
        Next i
    End If
lbl_Exit:
    Set oCC = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

[HTSCF Fareha]

Thanks for persevering with me Graham. I really wish that we didn't have to deal with RTF.

I was thinking that ideally your code suggestion from your last post could be put into the FixSpacing sub, but my attempt is failing.

[gmayor]

The code was meant to be used as a means of copying the contents of a properly formatted CC to your RTF application with the appropriate added spacing required by that format. It was not meant to be part of your existing code. However as you haven't said how you transfer the data to that application, it is difficult to advise. Didn't the document have the appropriate empty paragraphs before the recent changes to remove them?
If you want to include it in your code, call the following from the end of your code

Sub FormatCC()
Dim oCC As ContentControl
Dim oRng As Range
Dim oPara As Paragraph
Dim i As Long
Dim lCount As Long
    On Error Resume Next
    For Each oCC In ActiveDocument.ContentControls
        If oCC.Type = wdContentControlRichText Then
            Set oRng = oCC.Range
            oRng.ParagraphFormat.SpaceAfter = 0
            If oRng.Paragraphs.Count > 1 Then
                lCount = oRng.Paragraphs.Count - 1
                For i = lCount To 1 Step -1
                    oRng.Paragraphs(i).Range.InsertParagraphAfter
                Next i
            End If
        End If
    Next oCC
lbl_Exit:
    Set oCC = Nothing
    Set oRng = Nothing
    Set oPara = Nothing
    Exit Sub
End Sub

[HTSCF Fareha]

My bad Graham for not explaining myself clearly. The document is produced then the usual Ctrl A, Ctrl C with the final Ctrl V into the RTF entry area.

With the most recent FormatCC sub I can now report that everything is working fine.

Thank you again!