Microsoft Office

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
Dim oInlineShape As Word.InlineShape
'Проверка, что документ, в который будут вставляться фотографии, открыт.
    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, "JPG") = 0 And InStr(Файл.Type, "TIFF") = 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, "JPG") > 0 Or InStr(Файл.Type, "TIFF") > 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 Файл
    For Each oInlineShape In ActiveDocument.InlineShapes
    oInlineShape.Borders.OutsideLineStyle = wdLineStyleDouble
    oInlineShape.Borders.OutsideLineWidth = wdLineWidth150pt
Next oInlineShape
End Sub