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

Sub CompressPic()
 
SendKeys "оп~"
Application.CommandBars.ExecuteMso "PicturesCompress"
 
End Sub

With Application.FileSearch
  .LookIn = SearchPath
  .SearchSubFolders = True
  .FileType = msoFileTypeWordDocuments
   List = ""
   For i = 1 To .FoundFiles.Count
      List = List & .FoundFiles(i)
   Next i
End With

Sub BatchCompress()
  
  dirpath = "С:\Temp\"                                          'целевой каталог
  driveletter = Left(dirpath, 1)                                'диск
  ChDrive driveletter                                           'устанавливаем диск
  ChDir dirpath                                                 'устанавливаем путь
  cmd = " /c dir *.doc /s /b > dir.txt"                         'формируем строку для dir
  Shell Environ$("comspec") & cmd, vbHide                       'получаем список doc-файлов
 
  MsgBox "Dir List Created!"
 
  dirfile = dirpath & "dir.txt"                                 'путь к списку файлов (DOS CP866)
  Set dirlist = Documents.Open(dirfile, , , , , , , , , , msoEncodingOEMCyrillicII) 'открываем список
  For i = 1 To dirlist.Paragraphs.Count                         'перебираем строки списка
    With dirlist.Paragraphs(i).Range            
      fn = .Text
      fn = Replace(fn, vbCr, "")                                'удаляем CR/LF
      fn = Replace(fn, vbLf, "")
      Set od = Documents.Open(fn)                               'открываем doc-файл
      SendKeys "оп~"                                            'устанавливаем опции компрессии
      od.Application.CommandBars.ExecuteMso "PicturesCompress"  'выполняем сжатие рисунков
      od.Save                                                   'сохраняем файл
      od.Close                                                  'закрываем файл
    End With
  Next
 
  MsgBox "Compressing Finished!"
 
  dirlist.Close                                                 'закрываем список файлов
  
End Sub