Автор Тема: Word VBA Макросы: Ошибка в последовательности команд макроса.  (Прочитано 222 раз)

Оффлайн AV.P

  • Посетитель форума
  • Сообщений: 2
Макрос работает верно, кроме одной детали. Поле с автоматическим подсчетом изображений (необходимо для дальнейшего обновления) выводится в начало текста, игнорируя при этом последовательность команд.
Подскажите, как можно этого избежать.

Макрос
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

Оффлайн Администратор

  • Administrator
  • Сообщений: 1693
Макрос
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

Оффлайн AV.P

  • Посетитель форума
  • Сообщений: 2
Благодарю за ответ, и помощь в решении проблемы.