Does text in a table wrap?

[Robin Hammond]

This is a repost from .word.programming where I didn't attract a response.
Apologies for the cross post, but hopefully tables is a better group.

This is driving me nuts and there must be a better solution..

I have a routine hitting a database, creating a table or tables based on
extracted data. The objective is to have all these tables have uniform left
column width containing the row title, and a single uniform width for all
the other columns so that they format nicely within the overall document. We
also need to make sure that all the tables show the same column widths so
that things look consistent. The data in each cell of a table can vary in
length quite considerably depending on units etc, ranging from billions down
to percentages.

I can optimise the column widths for the number of characters ok, but need
to adjust the font size so that there is no text wrapping. To do this we
need to work out if there are any wrapped cells in each table. The following
function works but it is horribly slow, and some of my reports could contain
hundreds of tables. Checking each and every cell using the selection clause
below is an ugly solution.

So here's the question: Can anyone provide a better function that identifies
if any single cell in a table wraps.

Thanks in advance.

Robin Hammond
www.enhanceddatasystems.com

Public Function CheckNoWrapping(tblOutput As Table) As Boolean
Dim nRowCounter As Integer
Dim nColCounter As Integer
Dim rngCell As Range
'NOTE: preassumes that at least one row does not wrap

With tblOutput
For nColCounter = 1 To .Columns.Count
For nRowCounter = 1 To .Rows.Count
With .Cell(nRowCounter, nColCounter)
If .Range.Characters.Count = 1 Then GoTo SkipBlank
Set rngCell = .Range
rngCell.MoveEnd wdCharacter, -1
rngCell.Select
Selection.Collapse wdCollapseStart
Selection.EndKey wdLine
Selection.MoveRight wdCharacter, 1
Selection.MoveLeft wdCharacter, 1
If Selection.InRange(rngCell) = True Then
CheckNoWrapping = False
Exit Function
End If
End With
SkipBlank:
Next nRowCounter
Next nColCounter
End With
CheckNoWrapping = True
End Function

 

[Peter Hewett]

Hi Robin

Try the following code, It may be a little quicker:

Public Function RowWrap(ByVal tblItem As Word.Table) As Boolean
Dim celItem As Word.Cell
Dim rngCell As Word.Range
Dim rngCellEnd As Word.Range

For Each celItem In tblItem.Range.Cells
Set rngCell = celItem.Range

' Ignore empty cells
If Len(celItem.Range.Text) > 2 Then

' Set one range object to the start and
' another of the end of the range
Set rngCellEnd = rngCell.Duplicate
rngCell.Collapse wdCollapseStart
rngCellEnd.MoveEnd wdCharacter, -2
rngCellEnd.Collapse wdCollapseEnd

' If the vertical positions are different the row wraps
If rngCell.Information(wdVerticalPositionRelativeToPage) <> _
rngCellEnd.Information(wdVerticalPositionRelativeToPage) Then
MsgBox "C" & celItem.ColumnIndex & ", R" & _
celItem.RowIndex & " wraps"

' Slight optimisation as we don't need to search any more
RowWrap = True
Exit For
End If
End If
Next
End Function

Just pass the function a Word table object.

You're constrained in that you have to search each cell to see if there's
wrapped text. You could optimise it further if you only had to search
certain colummns or rows.

HTH + Cheers - Peter

 

[Robin Hammond]

Peter,

thanks for that. Sorry I didn't notice the response for a couple of days.
I'll give it a try and see how it benchmarks.

Robin Hammond
www.enhanceddatasystems.com