Как уменьшить потребление памяти в этом макросе под Word?

[baston]

Здравствуйте.
Есть макрос (код ниже), который вытаскивает замещающий текст из всех связанных рисунков в документе Word и помещает их в таблицу в новый документ. Если документ небольшой, то никаких проблем. Однако у меня есть документ свыше 300 страниц и вот при работе этого макроса с таким большим документом (много рисунков) постоянно появляется окно "Недостаточно памяти. ...".
Обращаю ваше внимание на то, что в документе есть и внедренные рисунки. Поэтому в макросе я исключаю такие объекты и выбираю лишь связанные, имеющие замещающий текст.
Вопрос: как избавиться от этого окна либо исключить потребление памяти? Спасибо!
Код макроса:

Код: Выделить всё

Sub extractAltText_to_NewDoc_rus()
'
'  Создаем список из всех замещающих надписей каждой картинки,
'  добавляя их в новый документ в таблицу
'
Dim altext As String       'замещающая надпись
Dim nAltext As Long        'количество замещающих надписей
Dim oShape As InlineShape  'связанная картинка
Dim oTable As Table        'таблица
Dim oRow As Row            'пустая строка
Dim newDoc As Document     'новый документ
Dim actDoc As Document     'активный документ
Dim ptWidth As Single      'ширина столбца таблицы

Application.ScreenUpdating = False


Set actDoc = ActiveDocument
Set newDoc = Documents.Add

nAltext = actDoc.InlineShapes.Count

With newDoc.PageSetup
   ptWidth = PicasToPoints(51) - (.RightMargin + .LeftMargin)
End With

Set oTable = newDoc.Tables.Add(Selection.Range, nAltext + 1, 2)

With oTable
   .Borders.Enable = True
   .Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
   .Rows.AllowBreakAcrossPages = False
   .TopPadding = PicasToPoints(0.5)
   .BottomPadding = PicasToPoints(0.5)
   .Columns(1).PreferredWidth = ptWidth * 0.65
   .Columns(2).PreferredWidth = ptWidth * 0.35
End With
With oTable.Cell(1, 1).Range
   .Font.Name = "Arial"
   .Font.Bold = True
   .InsertAfter "Замещающий текст"
End With
With oTable.Cell(1, 2).Range
   .Font.Name = "Arial"
   .Font.Bold = True
   .InsertAfter "Номер страницы"
End With

For Each oShape In actDoc.InlineShapes
   If oShape.Type = wdInlineShapeLinkedPicture Then
      If Len(oShape.AlternativeText) <> 0 Then
         altext = oShape.AlternativeText
         oTable.Rows.Add
         oTable.Rows.Last.Cells(1).Range.Text = altext
         oTable.Rows.Last.Cells(2).Range.Text = oShape.Range.Information(wdActiveEndPageNumber)
      End If
   End If
Next oShape

For Each oRow In oTable.Rows
    If Len(oRow.Cells(1).Range.Text) = 2 Then oRow.Delete
Next oRow

actDoc.Activate
Selection.HomeKey wdStory
Set newDoc = Nothing
Set actDoc = Nothing
Application.ScreenUpdating = True

End Sub