Автоматизировать процесс загрузки фото в word

Sub m_1()
Dim oDocument As Word.Document
Dim Флаг As Boolean
Dim oTable As Word.Table
Dim FileSystemObject As Scripting.FileSystemObject
Dim Папка As Scripting.Folder
Dim Файл As Scripting.File
Dim ИмяПапки As String
Dim Вопрос As String
Dim НеизвестныеФайлы As String
Dim oCell As Word.Cell
Dim i As Long
'Проверка, что документ, в который будут вставляться фотографии, открыт.
    For Each oDocument In Documents
        If oDocument.Name = "Вставка фотографий.doc" Then
            Флаг = True
            Exit For
        End If
    Next oDocument
    If Флаг = False Then
        MsgBox "Документ, в который надо вставлять фотографии, не открыт", vbExclamation
        Exit Sub
    End If
'Просмотр папки с фотографиями. Если в этой папке окажутся форматы
'(последние буквы после точки в названии файла), не указанные в коде,
'то будет создан их список. Если в этом списке окажутся фотографии,
'то в код надо добавить форматы этих фотографий. Если изменения в код
'не будут внесены, то эти файлы из списка не будут добавлены в документ,
'даже если они будут фотографиями.
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выберие папку с фотографиями"
        If .Show = 0 Then
            Exit Sub
        End If
        ИмяПапки = .SelectedItems(1)
    End With
    Вопрос = MsgBox("Была выбрана следующая папка" & vbCr & ИмяПапки, vbOKCancel + vbExclamation)
        If Вопрос = vbCancel Then
            Exit Sub
        End If
    Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
    Set Папка = FileSystemObject.GetFolder(ИмяПапки)
    For Each Файл In Папка.Files
        If InStr(Файл.Type, "JPEG") = 0 And InStr(Файл.Type, "PNG") = 0 And _
            InStr(Файл.Type, "TIF") = 0 And InStr(Файл.Type, "GIF") = 0 And _
            InStr(Файл.Type, "Точечный рисунок") = 0 Then
            НеизвестныеФайлы = НеизвестныеФайлы & vbCr & Файл.Name
        End If
    Next Файл
    If НеизвестныеФайлы <> "" Then
        Вопрос = MsgBox("В папке с фотографиями находятся неизвестные коду форматы файлов." & vbCr & _
                "Просмотреть эти файлы? Среди них могут оказаться фотографии.", _
                vbCritical + vbYesNo)
        If Вопрос = vbYes Then
            Set oDocument = Documents.Add
            oDocument.Range = НеизвестныеФайлы
            Exit Sub
        End If
    End If
'Помещение в переменную oDocument документа, в который вставляем фотографии.
'В дальнейшем, в коде будем указывать не документ, а переменную oDocument,
'которая и будет из себя представлять этот документ.
    Set oDocument = Documents("Вставка фотографий.doc")
    oDocument.Sections(1).PageSetup.Orientation = wdOrientLandscape
'Создание образца таблицы и помещение её в автотекст.
    With oDocument
        Set oTable = .Tables.Add(.Range(Start:=.Range.End - 1, End:=.Range.End - 1), _
            NumRows:=2, NumColumns:=2, DefaultTableBehavior:=wdWord8TableBehavior, _
            AutoFitBehavior:=wdAutoFitWindow)
            With oTable
                .Range.Cells.VerticalAlignment = wdCellAlignVerticalTop
                .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            End With
    End With
    NormalTemplate.AutoTextEntries.Add Name:="ТаблицаДляФотографий", Range:=oDocument.Tables(1).Range
'Добавление в документ новых таблиц и вставка в их ячейки фотографий.
    For Each Файл In Папка.Files
        If InStr(Файл.Type, "JPEG") > 0 Or InStr(Файл.Type, "PNG") > 0 Or _
            InStr(Файл.Type, "TIF") > 0 Or InStr(Файл.Type, "GIF") > 0 Or _
            InStr(Файл.Type, "Точечный рисунок") > 0 Then
            If i = 4 Then
                With oDocument
                    .Range(Start:=.Range.End - 1, End:=.Range.End - 1).InsertParagraph
                    NormalTemplate.AutoTextEntries("ТаблицаДляФотографий").Insert _
                        Where:=.Range(Start:=.Range.End - 1, End:=.Range.End - 1), RichText:=True
                End With
                i = 0
            End If
            i = i + 1
            oDocument.InlineShapes.AddPicture Файл.Path, SaveWithDocument:=True, _
                Range:=oDocument.Tables(oDocument.Tables.Count).Range.Cells(i).Range
        End If
    Next Файл
End Sub

oDocument.Sections(1).PageSetup.PaperSize = wdPaperA3

.Borders.OutsideLineStyle = wdLineStyleNone
.Borders.InsideLineStyle = wdLineStyleNone

Dim oInlineShape As Word.InlineShape

For Each oInlineShape In ActiveDocument.InlineShapes
    oInlineShape.Borders.OutsideLineStyle =
    oInlineShape.Borders.OutsideLineWidth =
Next oInlineShape

oDocument.Sections(1).PageSetup.PaperSize = wdPaperA3

.Borders.OutsideLineStyle = wdLineStyleSingle
.Borders.InsideLineStyle = wdLineStyleSingle
.Borders.OutsideColor = wdColorWhite
.Borders.InsideColor = wdColorWhite

'Проверка, что все фотографии имеют название.
Application.Run MacroName:="Normal.Module1.m_2"

Sub m_2()
Dim oInlineShape As Word.InlineShape
Dim НомераСтраниц As String
Dim oDocument As Word.Document
For Each oInlineShape In ActiveDocument.InlineShapes
    If oInlineShape.Range.Paragraphs(1).Range.Next(unit:=wdParagraph).Fields.Count > 0 Then
        If oInlineShape.Range.Paragraphs(1).Range.Next(unit:=wdParagraph).Fields(1).Type <> wdFieldSequence Then
            НомераСтраниц = НомераСтраниц & vbCr & oInlineShape.Range.Information(wdActiveEndPageNumber)
        End If
    ElseIf oInlineShape.Range.Paragraphs(1).Range.Next(unit:=wdParagraph).Fields.Count = 0 Then
        НомераСтраниц = НомераСтраниц & vbCr & oInlineShape.Range.Information(wdActiveEndPageNumber)
    End If
Next oInlineShape
If НомераСтраниц <> "" Then
    MsgBox "Не все фотографии имеют название. Номера страниц указаны в новом документе.", vbCritical
    Set oDocument = Documents.Add
    oDocument.Range = НомераСтраниц
End If
End Sub

Dim oField As Word.Field

'Форматирование номера названия.
For Each oField In oDocument.Fields
    If oField.Type = wdFieldSequence Then
        If InStr(oField.Code.Text, "SEQ № \* ARABIC") > 0 Then
            oField.Code.Text = " SEQ № \# " & Chr(34) & "00#" & Chr(34) & " "
        End If
    End If
Next oField
oDocument.Fields.Update

'Проверка, что все фотографии имеют название.
Application.Run MacroName:="Normal.Module1.m_2"