Пакетная обработка *.doc с рисунками внутри. Уменьшить качество рисунков.

Sub start()
DoFldr CreateObject("scripting.filesystemobject").getfolder("b:\temp") 'корневая папка
End Sub
 
Sub DoFldr(f)
Dim x
For Each x In f.Files
    If LCase(Mid(x.Name, InStrRev(x.Name, ".") + 1)) Like "doc*" Then DoFile x.Path
Next
For Each x In f.subfolders 'рекурсия
    DoFldr x
Next
End Sub
 
Sub DoFile(s)
With Documents.Open(s)
    Application.CommandBars.ExecuteMso "PicturesCompress"
    .Close wdSaveChanges
End With
Debug.Print s 'лог в окно Immediate - необязательно
End Sub

Application.CommandBars.FindControl(Id:=6382).Execute
SendKeys "%A%W{ENTER}", False

Application.CommandBars.FindControl(Id:=6382).Execute 
SendKeys "%A%W{ENTER}", False

SendKeys "оп~"
Application.CommandBars.FindControl(ID:=6382).Execute

Option Explicit
 
'Здесь создаём объект FileSystemObject, который
'будет доступен для всех процедур этого модуля.
Dim oFSO As New Scripting.FileSystemObject
    
'Для просмотра всех файлов в определённой папке, включая подпапки,
'буду использовать рекурсивную процедуру - это процедура,
'которая вызывает сама себя. функции Win32 API для этих целей нет -
'надо также использовать рекурсию. Это:
'cmd = " /c dir *.doc /s /b > dir.txt"
'Shell Environ$("comspec") & cmd, vbHide
'использовать не буду, т.к. не нашёл документации в интернете
'по использованию этих команд.
Sub Main()
    'Для удобства написания кода (чтобы когда ставили точку,
    'появлялись всплывающие подсказки) подключаем библиотеку классов:
    'Tools - References... - Microsoft Scripting Runtime.
    'Но подключение произойдёт только для одного компьютера,
    'на остальных компьютерах код не будет работать, поэтому надо
    'будет внести изменения в код - если это надо будет, тогда спросите.
    
    'Здесь указываем, какую папку надо будет просмотреть.
    'В этой папке будут просмотрены все подпапки.
    Const sMainFolder As String = "C:\Documents and Settings\Пользователь\Рабочий стол\Рисунки"
    'Запускаем рекурсивную процедуру Procedure1, которая будет находить
    'все doc-файлы и вносить в них изменения.
    Call Procedure1(sMainFolder)
    'Просто сообщение, что всё сделано.
    MsgBox "Работа завершена!", vbInformation
End Sub
 
Sub Procedure1(sFolderPath As String)
    'Процедура, которая находит все doc-файлы и вносит в них изменения.
    Dim oFolder As Scripting.Folder
    Dim oSubFolder As Scripting.Folder
    Dim oFile As Scripting.File
    Dim oDocument As Word.Document
    Set oFolder = oFSO.GetFolder(FolderPath:=sFolderPath)
    For Each oFile In oFolder.Files
        'lCase - на случай, если по каким-то причинам название файла
        'будет получено прописными буквами (большими).
        'Скрытые файлы с расширением ".doc" тоже считаются doc-файлами.
        'Например, когда открываем документ Word,
        'то в той же папке, где находится документ, создаётся скрытый файл.
        'Если такой файл открывать, то возникнет ошибка, поэтому
        'такие файлы, хоть они и имеют расширение ".doc", открывать не надо.
        'Скрытые файлы имеют вначале имени вот такие символы "~$".
        If LCase(oFile.Name) Like "*.doc" And LCase(Left(oFile.Name, 2)) <> "~$" Then
            'Собственно обработка файла.
            Set oDocument = Documents.Open(FileName:=oFile.Path)
            SendKeys String:="оп{ENTER}", Wait:=False
            Application.CommandBars.FindControl(ID:=6382).Execute
            oDocument.Close SaveChanges:=wdSaveChanges
        End If
    Next oFile
    'Здесь просматриваем вложенные папки (рекурсия здесь).
    For Each oSubFolder In oFolder.SubFolders
        'Запуск процедурой самой же себя.
        Call Procedure1(oSubFolder.Path)
    Next oSubFolder
End Sub

Sub BatchCompress()
  
  dpath = "H:\Tmp\Circle\" 'путь к папке
  drive = Left(dpath, 1)
  ChDrive drive
  ChDir dpath
  Shell Environ$("comspec") & " /c dir *.doc /s > fulldir.txt", vbHide
  Shell Environ$("comspec") & " /c dir *.doc /s /b > dir.txt", vbHide 
  MsgBox "File List Created!"
 
  With Documents.Open(FileName:="dir.txt", Encoding:=msoEncodingOEMCyrillicII)  
  For i = 1 To .Paragraphs.Count
    With .Paragraphs(i).Range
      fn = Replace(Replace(.Text, vbCr, ""), vbLf, "")
      With Documents.Open(fn)
        SendKeys "оп~" 'устанавка опций
        Application.CommandBars.ExecuteMso "PicturesCompress"
        .Close wdSaveChanges
      End With
    End With
  Next 
  .Close
  End With
  
  ChDrive drive
  ChDir dpath
  Shell Environ$("comspec") & " /c dir *.doc /s >> fulldir.txt", vbHide  
  MsgBox "Compressing Finished!"  
  Documents.Open FileName:="fulldir.txt", Encoding:=msoEncodingOEMCyrillicII 'файл отчёта
  
End Sub