MS Word - find table rows with wrapped text

Question

I have a table where all cells have Cell.WordWrap set to true. Some of them have text longer than cell width so it's wrapped. I need to find them (with longer text) and set them Cell.FitText = True, but can't figure how.

I tried to read row/cell .height. But it does not return real row/cell height but minimum height regardless how Cell.HeightRule is set.

Thanks for your tips!

Answer 1

One way to determine whether the content of a cell wraps is to compare the line numbering of the start and end of the cell content, as demonstrated in the following code example.

• The Word object model provides the Information property, which has numerous enumeration members, including wdFirstCharacterLineNumber.
• Each cell in a table is checked in a loop. After determining the line number of the first character in the cell, the Range is collapsed to its end-point (which is the beginning of the next cell), then moved back one character (putting it in the original cell) and the line number of the last character in the cell is checked.
• If the second is greater than the first, the cell is added to an array. (Note: possibly, you could process the cell directly. But if this could affect other cells, better to add them all to an array, first, then process the array.)
• Finally, the array is looped and each cell formatted with FitText = True

Sub ChangeCellWrapForLongLinesOfText()
        Dim tbl As Word.Table
        Dim cel As Word.Cell
        Dim rngCel As Word.Range
        Dim multiLineCells() As Word.Cell
        Dim firstLine As Long
        Dim lastLine As Long
        Dim i As Long, x As Long

        Set tbl = ActiveDocument.Tables(1)
        For Each cel In tbl.Range.Cells
            Set rngCel = cel.Range
            firstLine = rngCel.Information(wdFirstCharacterLineNumber)
            rngCel.Collapse wdCollapseEnd
            rngCel.MoveEnd wdCharacter, -1
            lastLine = rngCel.Information(wdFirstCharacterLineNumber)
            If lastLine > firstLine Then
                ReDim Preserve multiLineCells(i)
                Set multiLineCells(i) = cel
                i = i + 1
            End If
        Next
            'Debug.Print i, UBound(multiLineCells())
        For x = LBound(multiLineCells()) To UBound(multiLineCells())
            'Debug.Print multiLineCells(x).Range.Text
            multiLineCells(x).FitText = True
        Next
End Sub