Word VBA: Вставка изображений с названием с помощью макроса

[Yaros]

Добрый день!
Необходимо вставлять в документ большое количество картинок с названием.
Во вложении макрос (найден на просторах интернета).
В макросе нет вставки названия картинок.

Возможно ли сделать так, чтобы название и картинка всегда были на одном и том же листе?

Я не силен в VBA, поэтому прошу помощи.

Макрос

Sub InsertPicturesFromFolder()
    'Диалог выбора файлов
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выберите изображения"
        .Filters.Clear
        .Filters.Add "Изображения JPEG", "*.jpeg;*.jpg"
        .Filters.Add "Изображения PNG", "*.png"
        .Filters.Add "Изображения BMP", "*.bmp"
        .Filters.Add "Все изображения", "*.jpeg;*.jpg;*.png;*.bmp"
        .InitialView = msoFileDialogViewProperties
               
        If .Show Then
            Dim inshp As InlineShape, i As Integer
            For i = 1 To .SelectedItems.Count
                                               
                'Вставить название картинки из папки, которую выбрали перед каждой картинкой
                'Вставка изображения
                Set inshp = ActiveDocument.Paragraphs.Last.Range.InlineShapes.AddPicture(.SelectedItems(i), False, True)
               
                'Фиксация соотношения сторон
                inshp.LockAspectRatio = msoTrue
                'Добавляем ещё один абзац
                ActiveDocument.Paragraphs.Last.Range.InsertParagraphAfter
               
            Next
        Else
            Exit Sub
        End If
    End With
End Sub

[свернуть]

[Администратор]

Сделайте файл-пример. Вставьте в него одно изображение и название. Чтоб я представлял, что вы подразумеваете под названием.

[Yaros]

Пример с описанием во вложении.

[вложение удалено администратором]

[Администратор]

Макрос

Sub InsertPicturesFromFolder()
   
    Dim SelItems(), inshp As InlineShape
    Dim var, i As Long
   
   
    '1. Диалог выбора файлов.
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выберите изображения"
        .Filters.Clear
        .Filters.Add "Изображения JPEG", "*.jpeg;*.jpg"
        .Filters.Add "Изображения PNG", "*.png"
        .Filters.Add "Изображения BMP", "*.bmp"
        .Filters.Add "Все изображения", "*.jpeg;*.jpg;*.png;*.bmp"
        .InitialView = msoFileDialogViewProperties
        If .Show = 0 Then
            Exit Sub
        End If
        ReDim SelItems(1 To .SelectedItems.Count)
        For i = 1 To .SelectedItems.Count
            SelItems(i) = .SelectedItems(i)
        Next i
    End With
   
    ' Отключение монитора (может это ускорит макрос).
    Application.ScreenUpdating = False
   
    For i = 1 To UBound(SelItems)
                                   
        '2. Вставка имени файла (без расширения) перед картинкой.
        ' Запись в переменную имени файла.
        var = Dir(SelItems(i))
        ' Удаление расширения из имени файла.
        var = Left(var, InStrRev(var, ".") - 1)
        ' Вставка названия.
        ActiveDocument.Range.InsertAfter Text:=var
        ' Установка галочки "Не отрывать от следующего".
        ActiveDocument.Paragraphs.Last.KeepWithNext = True
        ' Вставка пустого абзаца после названия.
        ActiveDocument.Range.InsertParagraphAfter
        ' Убирание галочки "Не отрывать от следующего".
        ActiveDocument.Paragraphs.Last.KeepWithNext = False
       
        '3. Вставка изображения.
        Set inshp = ActiveDocument.Paragraphs.Last.Range.InlineShapes. _
            AddPicture(FileName:=SelItems(i), LinkToFile:=False, SaveWithDocument:=True)
       
        '4. Фиксация соотношения сторон.
        inshp.LockAspectRatio = msoTrue
       
        '5. Вставка двух пустых абзацев после рисунка.
        ActiveDocument.Range.InsertAfter String(2, Chr(13))
       
    Next i
   
    '6. Сообщение.
    Application.ScreenUpdating = True
    MsgBox "Готово.", vbInformation

End Sub

[свернуть]

[Yaros]

Огромное спасибо!

[vivka]

Здравствуйте, Администратор!
Не удержался, чтобы написать, что Ваши решения - просто супер! Я все их коллекционирую и на них учусь.
Спасибо!