VBA: добавляем в документ Word рисунки из любой папки и формируем подписи к рисункам

Недавно коллеги попросили помочь им с оформлением отчёта, в котором должно было быть приложение из кучи рисунков.

Рисунков было много, они лежали в отдельной папке и названия файлов рисунков в документе должны были быть оформлены в виде подписей к этим рисункам. Дополнительно, подписи к рисункам должны были быть пронумерованы и оформлены в соответствии с ГОСТом.

Делать это вручную муторно и долго, поэтому я написал небольшой скрипт, который сделает всю эту работу за пару секунд.

Private Sub vstavka_ris()

Dim iDialog As FileDialog
Dim FileItem As Object, ComItem As Object, ExtFile$

  'Выбираем папку с рисунками
    Set ComItem = CreateObject("Scripting.FileSystemObject")
    Set iDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    If Not iDialog.Show Then Exit Sub

     'Добавляем рисунки из папки в документ
    For Each FileItem In ComItem.getfolder(iDialog.SelectedItems(1)).Files

      ExtFile = LCase(Mid(FileItem.Name, InStrRev(FileItem.Name, ".") + 1))
      
      If ExtFile = "jpg" Or ExtFile = "jpeg" Or ExtFile = "bmp" _
      Or ExtFile = "gif" Or ExtFile = "png" Or ExtFile = "TIFF" _
      Or ExtFile = "tif" Or ExtFile = "emf" Or ExtFile = "eps" Then
        
        ActiveDocument.Paragraphs.Add.Range.InlineShapes.AddPicture(FileItem.Path).Select

        With Selection
          .Style = "Рисунок"  'Присваиваем объекту рисунок стиль "Рисунок"
          .InsertAfter vbCr  'Переходим на новую строку и добавляем нумерованную подпись
          .InsertCaption Label:="Рисунок" 
             'Подпись рисунка через тире (по госту) - название файла рисунка
          .InsertAfter ChrW(160) & "-" & ChrW(160) & ComItem.GetBaseName(FileItem.Name)
          .Next.Style = "Рисунок Название"  'Присваиваем подписи стиль "Рисунок Название"
        End With
          
      End If
    
    Next FileItem
    
End Sub

Перед запуском скрипта поместите курсор туда, куда вы собираетесь добавлять рисунки.

Я сознательно сформировал только 2 стиля для рисунков и для подписей к рисунку, и никаких дополнительных манипуляций со стилем рисунков и подписей к ним в скрипте я не делал, т.к. удобнее потом отредактировать эти 2 стиля чтобы "причесать" разом все рисунки и все подписи к ним во всём документе.

И да, не забывайте, что .InsertCaption Label:="Рисунок" это название подписи типа рисунок, этот тип у вас может называться под другому, пожалуйста проверьте у себя в word (меню Ссылки/вставить название). В случае, если у вас тип рисунка назван по-другому, используйте своё название (откорректируйте скрипт ... Label:="Ваше название подписи типа рисунок"

Естественно, вставьте в скрипт те названия стилей для рисунков и подписей к ним, которые используются в вашем документе. Удачи!

P.S. Уважаемый @Emulyator в комментариях предложил написать этот скрип используя только процедуру Dir и даже написал часть кода. С удовольствием поддерживаю эту инициативу ) Вот, какой у меня получился код в этом случае - работает аналогично:

Private Sub vstavka_ris()

Dim iDialog As FileDialog
Dim FileName$, ExtFile$, fNameNoExt$, FolderPath$

    Set iDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    If Not iDialog.Show Then Exit Sub
    
    FolderPath = iDialog.SelectedItems(1) & "\"
'    Debug.Print FolderPath
    
    FileName = Dir(FolderPath)

    While FileName <> "" And InStr(1, FileName, ".") > 0
        
        ExtFile = LCase(Mid(FileName, InStrRev(FileName, ".") + 1))
        fNameNoExt = Left(FileName, InStrRev(FileName, ".") - 1)
        
        If InStr(".jpg.jpeg.bmp.gif.png.emf.eps.", "." & ExtFile & ".") > 0 Then

            ActiveDocument.Paragraphs.Add.Range.InlineShapes.AddPicture(FolderPath & FileName).Select

            With Selection
              .Style = "Рисунок"
              .InsertAfter vbCr
              .InsertCaption Label:="Рисунок"
              .InsertAfter ChrW(160) & "-" & ChrW(160) & fNameNoExt
              .Next.Style = "Рисунок Название"
            End With
            
        End If
        
        FileName = Dir
        
    Wend
    
End Sub