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