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