Макрос работает верно, кроме одной детали. Поле с автоматическим подсчетом изображений (необходимо для дальнейшего обновления) выводится в начало текста, игнорируя при этом последовательность команд.
Подскажите, как можно этого избежать.
Макрос
Sub Вставить_фото_с_нумерацией()
Dim SelItems(), inshp As InlineShape
Dim var, i As Long
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)
'Вставка изображения
Set inshp = ActiveDocument.Paragraphs.Last.Range.InlineShapes. _
AddPicture(FileName:=SelItems(i), LinkToFile:=False, SaveWithDocument:=True)
ActiveDocument.Range.InsertParagraphAfter ' Вставка пустого абзаца
inshp.LockAspectRatio = msoTrue ' Фиксация соотношения сторон
'Вставка имени файла (без расширения)
' Вставка названия
ActiveDocument.Content.InsertAfter Text:="Фото №"
' Вставить номер рисунка
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldSequence, Text:="Фото_№ \* ARABIC", _
PreserveFormatting:=False
var = Dir(SelItems(i)) ' Запись в переменную имени файла
var = Left(var, InStrRev(var, ".") - 1) ' Удаление расширения из имени файла
ActiveDocument.Content.InsertAfter Text:=" """
ActiveDocument.Range.InsertAfter Text:=var
ActiveDocument.Content.InsertAfter Text:=""""
ActiveDocument.Range.InsertParagraphAfter ' Вставка пустого абзаца после названия
Next i
'Изменяем размеры всех изображений
For Each inshp In Application.ActiveDocument.InlineShapes 'Для каждого рисунка в документе
inshp.Height = 200 'Изменить высоту
Next inshp
End Sub
Макрос
Sub Вставить_фото_с_нумерацией()
Dim SelItems(), inshp As InlineShape
Dim rng As Range, var, i As Long
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)
'Вставка изображения
Set inshp = ActiveDocument.Paragraphs.Last.Range.InlineShapes. _
AddPicture(FileName:=SelItems(i), LinkToFile:=False, SaveWithDocument:=True)
ActiveDocument.Range.InsertParagraphAfter ' Вставка пустого абзаца
inshp.LockAspectRatio = msoTrue ' Фиксация соотношения сторон
' Вставка названия.
'1) Вставка текста названия.
ActiveDocument.Content.InsertAfter Text:="Фото №"
'2) Устанавливаем невидимый курсор в конец текста.
Set rng = ActiveDocument.Range
rng.Collapse Direction:=wdCollapseEnd
'3) Вставка поля.
ActiveDocument.Fields.Add Range:=rng, Type:=wdFieldSequence, Text:="Фото_№ \* ARABIC", _
PreserveFormatting:=False
var = Dir(SelItems(i)) ' Запись в переменную имени файла
var = Left(var, InStrRev(var, ".") - 1) ' Удаление расширения из имени файла
ActiveDocument.Content.InsertAfter Text:=" """
ActiveDocument.Range.InsertAfter Text:=var
ActiveDocument.Content.InsertAfter Text:=""""
ActiveDocument.Range.InsertParagraphAfter ' Вставка пустого абзаца после названия
Next i
'Изменяем размеры всех изображений
For Each inshp In Application.ActiveDocument.InlineShapes 'Для каждого рисунка в документе
inshp.Height = 200 'Изменить высоту
Next inshp
End Sub