Тема: Вставка картинок с именами файлов.
Доброго времени суток всем.
Ломаю голову уже неделю, так и не могу решить проблему. В VB я туговат, но нужно решить задачу.
Дано: Папка с фотографиями. Пустой документ "Вставка фотографий". Часть кода.
Нужно сделать: Вставить фотографии в документ по 4 шт на лист 2х2 (это часть кода решает) и нужно чтобы под каждым фото было имя файла фото. Т.е. у меня фотки в папке уже переименованы как фото 001, фото 002 и тд. Нужно чтобы под каждой фотографией стояло название фото 001, соответствующее имени файла. (Вроде бы понятно написал)
Вот часть кода, которую нашел в и-нете
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
Помогите пожалуйста. Начальник отдела для которого решается эта задача уже начинает психовать и орать, что для чего нужен такой спец, что не может решить проблему.
P.S. Извините если нарушил правила, я на форуме новичок и не очень разобрался с движком.