MS Word - find table rows with wrapped text - vba

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