VBA loop freezes/crashes word после первой итерации

Question

Попытка определить общую ширину каждой таблицы в текстовом документе. После первой итерации скрипт зависает, и Microsoft Word перестает отвечать на запросы.

Sub fixTableAlignment() 
    For Each tTable In ActiveDocument.Tables 
     Dim tRng As Range 
     Dim sngWdth As Single 
     Set tRng = tTable.Cell(1, 1).Range 
     sngWdth = -tRng.Information(wdHorizontalPositionRelativeToPage) 
     Do While tRng.Cells(1).RowIndex = 1 
     tRng.Move unit:=wdCell, Count:=1 
     Loop 
     tRng.MoveEnd wdCharacter, -1 
     sngWdth = sngWdth + tRng.Information(wdHorizontalPositionRelativeToPage) 
     MsgBox PointsToInches(sngWdth) 
    Next tTable 
    End Sub 

Answer 1

Представленный код не работает для таблиц, состоящих из одной строки. Это Do While петля:

Do While tRng.Cells(1).RowIndex = 1 
    tRng.Move unit:=wdCell, Count:=1 
Loop 

разразится когда мы находим ячейку, которая не находится в строке 1. Если имеется только одна строка, то каждая ячейка в строке 1.

Метод Move возвращает 0 если этот шаг оказался неудачным, так это должно работать:

Dim lngSuccess As Long 

For Each ttable In ThisDocument.Tables 
    Set tRng = ttable.Cell(1, 1).Range 
    sngWdth = -tRng.Information(wdHorizontalPositionRelativeToPage) 

    ' Any non-zero value will do here 
    lngSuccess = 1 
    Do While tRng.Cells(1).RowIndex = 1 And lngSuccess <> 0 
    lngSuccess = tRng.Move(unit:=wdCell, Count:=1) 
    Loop 

    tRng.MoveEnd wdCharacter, -1 
    sngWdth = sngWdth + tRng.Information(wdHorizontalPositionRelativeToPage) 
    MsgBox PointsToInches(sngWdth) 
Next tTable 

следует также отметить: tTable не объявлен в исходном коде так объявит его в методе (и использовать Option Explicit, если уже не делать этого). Часть кода, вызвавшего ошибку можно было выследить, нажав <Ctrl>-<Break> когда Слово перестает отвечать - это привело бы вас прямо к петле While

---

редактировать, чтобы иметь дело с неправильной шириной в таблицах однорядные :

Эта новая версия использует свойство Cell.Width для измерения ширины таблицы. Я не мог найти надежный способ использования Range.Information для измерения ширины таблицы однорядной

Option Explicit 

Sub fixTableAlignment() 
    Dim tTable As Table 
    Dim cCell As Cell 
    Dim sngWdth As Single 
    Dim bFinished As Boolean 

    For Each tTable In ThisDocument.Tables 
     Set cCell = tTable.Cell(1, 1) 
     sngWdth = 0 

     ' Can't just check the row index as cCell 
     ' will be Nothing when we run out of cells 
     ' in a single-row table. Can't check for 
     ' Nothing and also check the row index in 
     ' the Do statement as VBA doesn't short-circuit 
     bFinished = False 
     Do Until bFinished 
      sngWdth = sngWdth + cCell.Width 
      Set cCell = cCell.Next 

      If (cCell Is Nothing) Then 
       bFinished = True 
      ElseIf (cCell.RowIndex <> 1) Then 
       bFinished = True 
      End If 
     Loop 

     MsgBox PointsToInches(sngWdth) 
    Next tTable 
End Sub