Добрый день!
Необходимо вставлять в документ большое количество картинок с названием.
Во вложении макрос (найден на просторах интернета).
В макросе нет вставки названия картинок.
Возможно ли сделать так, чтобы название и картинка всегда были на одном и том же листе?
Я не силен в 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
Сделайте файл-пример. Вставьте в него одно изображение и название. Чтоб я представлял, что вы подразумеваете под названием.
Пример с описанием во вложении.
[вложение удалено администратором]
Макрос
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