11.11.2023 16:38
Kutush 8 1900 Источник

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

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

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

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:="Ваше название подписи типа рисунок"

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

Комментарии (8)


  1. Emulyator
    11.11.2023 19:18
    #26149464

    Не заработало в 2003 ворде... Почему не использовать встроенную в vba функцию Dir вместо создания "Scripting.FileSystemObject"? Даже новомодные ГПТ чаты её используют, если им предложить решить эту задачу. )


    1. Kutush Автор
      11.11.2023 19:18
      #26151068

      А какие ошибки выдаёт и на каких строках?

      Наверно можно использовать функцию Dir, использовал что под рукой было. ) Я не ставил себе задачу сделать универсальный стабильный и оптимальный скрипт, у меня была задача решить проблему, решил так как получилось. ))

      Я больше хочется чтобы скрипт был максимально простой и понятный и пользователь его мог легко модифицировать под свои нужды.

      Если не трудно, подскажите как можно использовать в этом случае функцию Dir.


      1. Emulyator
        11.11.2023 19:18
        #26151932

        With Selection
          .Style = "Рисунок"  'Присваиваем объекту рисунок стиль "Рисунок"

        Run time error 5834 Элемент с указанным именем не существует , наверное не находит стиль с таким названием.

        я обычно стараюсь не использовать функции типа CreateObject, разве что если других вариантов нет. 

        ....
    FileName = Dir(FolderPath)
    While FileName <> "" And InStr(1, FileName, ".") > 0
        ExtFile = LCase(Mid(FileName, InStrRev(FileName, ".") + 1))
        If InStr(".jpg.jpeg.bmp.gif.png.emf.eps.", "." & ExtFile & ".") > 0 Then
            Debug.Print FileName
            'какие-то действия
        End If
        FileName = Dir
    Wend


        1. Kutush Автор
          11.11.2023 19:18
          #26152024

          Ну да, должен существовать стиль с названием "Рисунок". Нужно или изменить название стиля в скрипте на тот который используется у вас в документе word для рисунков и подписей к рисункам, либо создать стили с названием "Рисунок" и "Рисунок Название" у вас в документе, по идее всё должно работать.

          Попробую на днях создать 2-й вариант скрипта с использованием функции dir


  1. Squoworode
    11.11.2023 19:18
    #26149816
    +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

    А почему бы не

    if instr("/jpg/jpeg/bmp/gif/png/TIFF/tif/emf/eps/", "/"+ExtFile+"/") then

    ?


    1. Radisto
      11.11.2023 19:18
      #26149860

      Есть подозрения (которые конечно лучше бы проверить), что куча ifов работает быстрее (правда это имеет смысл, когда файлов много, для разовой работы конечно лучше выбрать что проще)


    1. Kutush Автор
      11.11.2023 19:18
      #26151076

      Можно наверно, но я старался писать максимально простой и понятный код, который мог использовать (и модифицировать под себя) даже человек мало смыслящий в VBA...


      1. PereslavlFoto
        11.11.2023 19:18
        #26151690
        +2

        Тут надо было сделать функцию, внутрь которой убрать проверки. Потому что это проще поддерживать.