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. :banghead:

29503



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. :doh:

[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. :doh:

[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!