Schrödinger's paragraph

[genja]

Hi everyone,



maybe I am overlooking something very obvious... but, as the topic suggests I have a problem with paragraphs that appear to both exist and not to exist at the same time.


The problem occurs always when when there is an empty paragraph at the end of a content control. I am looking for a way to target this paragraph efficiently and remove it.

My problem is mainly that I cannot find a way to target these paragraphs directly for whatever reason!

I've built a small example to demonstrate my problem:
Lets say I have a content control cc in that one can select three paragraphs (screenshot) of which the last one is empty. The test document looks like this:


It has 6 paragraphs in total of which 2 are placed before the content control, three are or lets say should be within the cc and one is/should be after the cc. The cc is a rich text cc, if that matters.

When I run the code

Sub countParasInCC()
    Dim doc As Document, cc As ContentControl, ccRange As Range, paraCountCC As Integer, myccTitle As String
    Set doc = ActiveDocument
    myccTitle = "ccTitle"
    Set cc = doc.SelectContentControlsByTitle(myccTitle).Item(1)
    Set ccRange = cc.Range
    paraCountCC = ccRange.Paragraphs.Count
 End Sub

the result is paraCountCC = 2.


However, when i run the code

Sub countParasDocument()
    Dim doc As Document, paraCountDoc As Integer
    Set doc = ActiveDocument
    paraCountDoc = doc.Range.Paragraphs.Count
End Sub

I get paraCountDoc = 6.



Can somebody explain to me why the empty paragraph is not counted when counting paragraphs in the cc's range but is counted when counting paragraphs in the document range? What is the method to target and remove such paragraphs?


Many thanks in advance!

[gmaxey]

It is just a empty paragraph that Microsoft has pressed a placeholder role on.


Select your empty paragraph in the CC and step through this code:

Sub SSM()
Dim oCC As ContentControl
Dim oPar As Paragraph
Dim oRng As Range
Dim lngIndex As Long
  Set oCC = ActiveDocument.SelectContentControlsByTitle("ccTitle").Item(1)
  MsgBox oCC.Range.Paragraphs.Count
  'Select the empty paragraph that appears to be in the CC.  Is it really there?
  MsgBox Selection.InRange(oCC.Range)
  'No.  Try to delete it.
  Selection.Range.Delete
  'You can't. Why?
  'Show the tags. Notice the selection shift
  oCC.Appearance = wdContentControlTags
  'It is smoke and mirrors.  The empty paragraph is the placeholder for the XML tags
  For lngIndex = ActiveDocument.Paragraphs.Count To 1 Step -1
    If Selection.Range.InRange(ActiveDocument.Paragraphs(lngIndex).Range) Then
      ActiveDocument.Paragraphs(lngIndex).Range.Delete
    End If
  Next
lbl_Exit:
  Exit Sub
End Sub

[genja]

Thanks Greg, that put me in the right direction. I thought that I can target the paragraph within the cc specifically but now I just iterate through the entire document.

My goal is to find all empty paragraphs in documents with 3000 (or sometimes more) paragraphs that do not contain necessary breaks and delete them. Tables are excluded by design. There is some redundancy in the code regarding the checking for the breaks which I was too lazy to remove. I am fairly new to VBA, so, if anyone has a suggestion for improvement, please share your thoughts.

Sub delete_empty_paras()
 Dim doc As Document, para As Paragraph, paraNext As Paragraph, paraRng As Range, _
 paraLen As Integer, delCount As Integer, paraCount_pre As Integer, paraCount_post As Integer
     StartTime = Timer
    Set doc = ActiveDocument: Set para = doc.Paragraphs.First
    Do While Not para Is Nothing
        Set paraNext = para.Next
        If para.Range.Tables.count > 0 Then GoTo Skip
        Set paraRng = para.Range: paraLen = Len(para.Range.text)
        If paraRng.text = ChrW(12) Then GoTo Skip:If paraRng.text = "^m" Then GoTo Skip
        If paraLen <= 2 Then
            If Not ContainsBreaks(paraRng) And Not ContainsShapesOrImages(paraRng) Then
                paraCount_pre = doc.Paragraphs.count
                'paraRng.Select 'debugging
                paraRng.Delete: paraCount_post = doc.Paragraphs.count: del = IIf(paraCount_post <> paraCount_pre, 1, 0)
                delCount = delCount + del
            End If
        End If
Skip:
        Set para = paraNext
    Loop
     Debug.Print "Paragraphs deleted: " & delCount & "  |  Execution time: " &  _
                  Round(Timer - StartTime, 2) & " s  |  " & Format((Timer - StartTime) / 60, "0.00") & " min"
   End Sub

Function ContainsShapesOrImages(rng As Range) As Boolean
    Dim iLshp As InlineShape, shp As shape
    Dim found As Boolean
    found = False
    For Each iLshp In rng.InlineShapes 'check for InlineShapes
        found = True: Exit For
    Next iLshp
    If Not found Then 'check for regular shapes. do I even need this?
        For Each shp In rng.ShapeRange
            found = True: Exit For
        Next shp
    End If
    ContainsShapesOrImages = found
End Function

Function ContainsBreaks(rng As Range) As Boolean
     Dim searchText As Variant, found As Boolean, i As Integer
    searchText = Array("^b", "^m", "^12", "^n") 'checks for specific breaks
    found = False
    With rng.Find
        .ClearFormatting: .Forward = True: .Wrap = wdFindStop: .MatchWildcards = False
        For i = LBound(searchText) To UBound(searchText)
            .text = searchText(i)
            If .Execute Then: found = True: Exit For 'exit when found
        Next i
    End With
    ContainsBreaks = found
 End Function

 Function StopTimer(StartTime As Double) As Double
    Dim elapsedTime As Double
    elapsedTime = Timer - StartTime
    StopTimer = elapsedTime
End Function

[gmaxey]

I think you are adding more bells and whistles than your really need. There is really no need to evaluate every paragraph. Perhaps something like:

Sub DeleteEmptyParagraphs()
Dim oRng As Range
Dim lngST As Long, lngCount As Long, lngIndex As Long
Dim oPar As Paragraph
  lngST = Timer
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .Text = Chr(13) & "{2,}"
    .MatchWildcards = True
    While .Execute
      For lngIndex = oRng.Paragraphs.Count To 1 Step -1
        Set oPar = oRng.Paragraphs(lngIndex)
        If Len(oPar.Range.Text) = 1 Then
          oPar.Range.Select
          Select Case AscW(oPar.Range.Characters.Last.Next)
            Case 12 'Do nothing
            Case Else
              oPar.Range.Delete
              lngCount = lngCount + 1
          End Select
        End If
      Next lngIndex
      oRng.Collapse wdCollapseEnd
    Wend
  End With
  MsgBox "Paragraphs deleted: " & lngCount & "  |  Execution time: " & _
              Round(Timer - lngST, 2) & " s  |  " & Format((Timer - lngST) / 60, "0.00") & " min"
lbl_Exit:
  Exit Sub
End Sub

[genja]

Thanks again Greg. I Like the idea but I cannot get it to work the way you intend.

I get error 5560 on line

While .Execute

I've tried to modify the search string

.Text = Chr(13) & "{2,}"

to search for Chr(13)&Chr(13) for testing purposes. Doing this lets the code execute further and results in error 5 on line

Select Case AscW(oPar.Range.Characters.Last.Next)

The Problem seems to be with the .Next. Not sure if these methods can be combined like that.

Besides that, why exactly do you use step -1 and why a 'for x=z to y' loop? Wouldn't it be much faster to to iterate manually when dealing with large documents? Like

i = 1
For each oPar in ActiveDocument.Paragraphs
    ...<code>
    Set oPar = ActiveDocument.Paragraphs(i)
    ...<code>
    i = i +1
Next oPar

[gmaxey]

genja,


Well obviously I failed to do exhaustive testing
My point was to try to convey that there is little point in evaluating every paragraph against the next. For Example if Leo Tolstoy would have inadvertently left a couple of empty paragraphs in War and Peace, why evaluate the whole book.

First find any instance where two or more paragraphs appear, then evaluate if the condition warrants removing them. I also failed it include the very issue you first posted about!


Anyway. Let's try again. Again the testing is not exhaustive but here at least the code is doing better. As for your error on .Text = Chr(13) & "{2,} ... that may be due to your regional settings "," may not be your defined list separator.

Sub DeleteEmptyParagraphs()
Dim oRng As Range, oRngEval As Range
Dim lngST As Long, lngCount As Long
Dim oPar As Paragraph
  lngST = Timer
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .Text = Chr(13) & "{2,}"
    .MatchWildcards = True
    While .Execute
      Set oRngEval = oRng.Duplicate
      Set oPar = oRngEval.Paragraphs(1)
      Do While Not oPar Is Nothing
        oPar.Range.Select
        Select Case True
          Case Len(oPar.Range.Text) = 1
            Select Case True
              Case oPar.Range.End = ActiveDocument.Range.End
                oPar.Range.Delete
                lngCount = lngCount + 1
              Case oPar.Range.Text = ChrW(12) Or oPar.Range.Characters.Last.Next = ChrW(12)
              Set oPar = oPar.Next
              Case Else
                oPar.Range.Delete
                lngCount = lngCount + 1
            End Select
          Case Else
            Set oPar = oPar.Next
         End Select
        Loop
      oRng.Collapse wdCollapseEnd
    Wend
  End With
  MsgBox "Paragraphs deleted: " & lngCount & "  |  Execution time: " & _
              Round(Timer - lngST, 2) & " s  |  " & Format((Timer - lngST) / 60, "0.00") & " min"
lbl_Exit:
  Exit Sub
End Sub