Как сделать так, чтобы таблица Word точно соответствовала странице с помощью VBA

Question

Я хотел бы сделать что-то вроде: AutoFitBehavior(wdAutoFitWindow) в таблице Word, но:

1. Я не хочу, чтобы текст в ячейках переносился (поэтому я использую Rows.HeightRule = wdRowHeightExactly).
2. Если текст слишком большой для таблицы, чтобы поместиться на странице, я бы хотел, чтобы к самым большим ячейкам применялась FitText, пока она не сделает
3. Нужно обрабатывать таблицы с объединенными ячейками

Я опубликую свою попытку в качестве ответа, но мне интересно, есть ли лучший способ?

Answer 1

Я предварительно вычисляю желаемую ширину таблицы и передаю ее в следующую Fit функцию:

Sub Fit(pTable As Word.Table, pWidth As Integer)
    Dim oCell As Word.Cell
    Dim oRefCell As Word.Cell
    Dim oDict As New Scripting.Dictionary
    Dim nThisColumnWidth As Double
    Dim nTableWidth As Double
    Dim oToFit As New Collection

    Call pTable.AutoFitBehavior(wdAutoFitContent)

    For Each oCell In pTable.Range.Cells
        If Len(oCell.Range.Text) > 8 Then
            Call oDict.Add(oCell, Len(oCell.Range.Text))
        End If
    Next
    Set oDict = SortDict(oDict)

    For Each oCell In oDict
        Let nTableWidth = 0
        For Each oRefCell In pTable.Rows(1).Cells
            Let nTableWidth = nTableWidth + oRefCell.Width
        Next
        If nTableWidth < pWidth Then
            Exit For
        End If
        oCell.Range.Font.Hidden = True
        Call oToFit.Add(oCell)
        DoEvents
    Next
    For Each oCell In oToFit
        oCell.FitText = True
        oCell.Range.Font.Hidden = False
    Next

    Call pTable.AutoFitBehavior(wdAutoFitWindow)
End Sub
Function SortDict(ByRef oDict)
    Dim i As Integer
    Dim j As Integer
    Dim oKeys

    oKeys = oDict.Keys
    Call QuickSort(oDict, oKeys)

    Set SortDict = New Scripting.Dictionary

    For i = UBound(oKeys) To LBound(oKeys) Step -1
        Call SortDict.Add(oKeys(i), oDict.Item(oKeys(i)))
    Next
End Function
Public Sub QuickSort(ByRef oDict, ByRef pvarArray As Variant, Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long)
    Dim lngFirst As Long
    Dim lngLast As Long
    Dim varMid As Long
    Dim varSwap As Variant

    If plngRight = 0 Then
        plngLeft = LBound(pvarArray)
        plngRight = UBound(pvarArray)
    End If
    lngFirst = plngLeft
    lngLast = plngRight
    varMid = oDict.Item(pvarArray((plngLeft + plngRight) \ 2))
    Do
        Do While oDict.Item(pvarArray(lngFirst)) < varMid And lngFirst < plngRight
            lngFirst = lngFirst + 1
        Loop
        Do While varMid < oDict.Item(pvarArray(lngLast)) And lngLast > plngLeft
            lngLast = lngLast - 1
        Loop
        If lngFirst <= lngLast Then
            Set varSwap = pvarArray(lngFirst)
            Set pvarArray(lngFirst) = pvarArray(lngLast)
            Set pvarArray(lngLast) = varSwap
            lngFirst = lngFirst + 1
            lngLast = lngLast - 1
        End If
    Loop Until lngFirst > lngLast
    If plngLeft < lngLast Then QuickSort oDict, pvarArray, plngLeft, lngLast
    If lngFirst < plngRight Then QuickSort oDict, pvarArray, lngFirst, plngRight
End Sub

кредит vbforums за алгоритм сортировки