Создать файл из картинок каждой страницы Word

Sub CopyPages2Pics()
       
    Dim rng As Range
    Dim i As Integer, nPages as Integer
    Dim oDoc As Document, nDoc As Document
       
    Set oDoc = ActiveDocument  'исходный документ, в который впендюрен макрос
    Set nDoc = Documents.Add   'новый документ
        
    nPages = oDoc.BuiltInDocumentProperties(wdPropertyPages) 'число страниц
    For i = 1 To nPages Step 1            'создадим в новом документе столько же 
        nDoc.Range.Paragraphs.Add         ' параграфов, сколько страниц в исходном
        With nDoc.Paragraphs.Item(i)      ' причём каждый параграф
          .Range = " "                    ' содержит пустой пробел
          .PageBreakBefore = True        ' и начинается с новой страницы
        End With
    Next
       
    For i = nPages To 1 Step -1 'Идём по исходным страницам снизу
       
         Set rng = oDoc.GoTo(what:=wdGoToPage, which:=wdGoToAbsolute, Count:=i)
         rng.Select  'эта часть кода стырена в сети
       
         Set rng = Selection.Bookmarks("\page").Range
         rng.Select
         rng.Copy
       
         nDoc.Paragraphs(i).Range.Characters.First.Select
         Selection.PasteSpecial , , , , 3 'Вставляем то что в буфере, как КАРТИНКУ
    Next i
    For Each pic In nDoc.Shapes 'для всех вставленных картинок
      pic.WrapFormat.Type = 4   'включим обтекание текстом сверху и снизу
    Next
    nDoc.SaveAs oDoc.Path & "\" & Replace(oDoc.Name, ".doc", "") & "-NEW" 'сохраним новый файл с новым имененм
       
    nDoc.Close
       
    Set rng = Nothing
    Set nDoc = Nothing
    Set oDoc = Nothing
       
End Sub

option explicit
  dim wrd, FSO, wDir, wFiles, WF, DocPic, ArhDir
  Set FSO = CreateObject("Scripting.FileSystemObject") 
  wDir = FSO.GetAbsolutePathname("") ' здесь можно написать прямой путь к папке  исходных файлов
  Arhdir = fso.BuildPath(wDir,"ARH") 'либо пишите сюда вашу папку для перемещения обработанных исходных файлов
  DocPic = fso.BuildPath(wDir,"NEW") 'либо пишите сюда вашу папку для файлов с картинками на страницах
  IF NOT fso.FolderExists(ArhDir) Then FSO.CreateFolder ArhDir
  IF NOT fso.FolderExists(DocPic) Then FSO.CreateFolder DocPic
  Set wFiles = CreateObject("Shell.Application").NameSpace(wDir).Items() 'всё что есть в нашей папке
  wFiles.Filter 64, "*.doc*" 'смотрим только на файлы doc*
  if wFiles.Count < 1 Then  wsh.echo "Не *.doc* in: " & wDir:  wsh.quit
  Set wrd = CreateObject("Word.Application")
  wrd.Visible = True'после отладки можно поставить False, чтобы Word запускался в невидимом режиме
  for each WF in wFiles
    MakeDocPic WF.Path
    FSO.MoveFile wf.Path, ArhDir & "\"
  next
  wrd.quit
  Set FSO=Nothing: Set wFiles = Nothing: Set wrd = Nothing
  wsh.echo "Finished"
  wsh.quit
 
Sub makeDocPic(fPath)
  dim oDoc, nDoc, i, npages, pic, rng, tm
  Set oDoc = wrd.Documents.open(fPath)  'исходный документ, в который впендюрен макрос
  Set nDoc = wrd.Documents.Add   'новый документ
        
  nPages = oDoc.BuiltInDocumentProperties(14) 'число страниц
  For i = 1 To nPages Step 1            'создадим в новом документе столько же 
      nDoc.Range.Paragraphs.Add         ' параграфов, сколько страниц в исходном
      With nDoc.Paragraphs.Item(i)      ' причём каждый параграф
        .Range = " "                    ' содержит пустой пробел
        .PageBreakBefore = True        ' и начинается с новой страницы
      End With
  Next
       
  For i = nPages To 1 Step -1 'Идём по исходным страницам снизу
       
       Set rng = oDoc.GoTo(1, 1, i)
       rng.Select  'эта часть кода стырена в сети
       
       Set rng = wrd.Selection.Bookmarks("\page").Range
       rng.Select
       rng.Copy
       tm = NOW+1/86400
       do WHILE NOW() < tm ' могут быть сбои: в момент вставки ещё антивирь не отпустил буфер и надо ждать секунду.
'         doEVENTS
       loop
       nDoc.Paragraphs(i).Range.Characters.First.Select
       wrd.Selection.PasteSpecial , , , , 3 'Вставляем то что в буфере, как КАРТИНКУ
  Next 
    For Each pic In nDoc.Shapes 'для всех вставленных картинок
      pic.WrapFormat.Type = 4   'включим обтекание текстом сверху и снизу
    Next
    nDoc.SaveAs FSO.BuildPath(docPic, FSO.GetBasename(fPath)) 'сохраним новый файл в новую папку
    nDoc.Saved = True   
    nDoc.Close
    oDoc.Saved = True
    oDoc.Close
    Set oDoc = Nothing: Set nDoc = Nothing: Set pic = Nothing: Set rng = Nothing
end sub

Sub aaa1()
'
' aaa1
'
'
 
 
 
       
    Dim rng As Range
    Dim i As Integer, nPages As Integer
    Dim oDoc As Document, nDoc As Document
       
    Set oDoc = ActiveDocument
    Set nDoc = Documents.Add 
        
    nPages = oDoc.BuiltInDocumentProperties(wdPropertyPages) 
    For i = 1 To nPages Step 1         
        nDoc.Range.Paragraphs.Add         '
        With nDoc.Paragraphs.Item(i)      ' 
          .Range = " "                    ' 
          .PageBreakBefore = True         '
        End With
    Next
       
    For i = nPages To 1 Step -1 ' Èäåì ïî èñõîäíûì ñòðàíèöàì ñíèçó
       
         Set rng = oDoc.GoTo(what:=wdGoToPage, which:=wdGoToAbsolute, Count:=i)
         rng.Select  
       
         Set rng = Selection.Bookmarks("\page").Range
         rng.Select
         rng.Copy   ' error
       
         nDoc.Paragraphs(i).Range.Characters.First.Select
         Selection.PasteSpecial , , , , 3 '
    Next i
    For Each pic In nDoc.Shapes '
      pic.WrapFormat.Type = 4   ' 
    Next
'    nDoc.SaveAs oDoc.Path & "" & Replace(oDoc.Name, ".doc", "") & "-NEW" '
       
'    nDoc.Close
       
    Set rng = Nothing
    Set nDoc = Nothing
    Set oDoc = Nothing
       
 
End Sub

nDoc.SaveAs oDoc.Path & "\" & Replace(oDoc.Name, ".doc", "") & "-NEW" '