Sub фотки()
Dim fs As New FileSystemObject
Dim fl As Folder
Dim fls As Files
Dim f As File
Dim v() As String, bln As Boolean, bln1 As Boolean, bln2 As Boolean
Dim i As Integer
Dim j As Integer, sleva As Integer, sverhy As Integer
Dim path As String
path = "C:\Documents and Settings\Администратор\Мои документы\сименс\печать\"
Set fl = fs.GetFolder(path)
Set fls = fl.Files
ReDim v(1 To fls.Count)
For Each f In fls
i = i + 1
v(i) = f.Name
Next
sverhy = 1
sleva = 2
bln = True
bln1 = False
For i = 1 To fls.Count
If bln = False Then
sleva = 15
ThisDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, CentimetersToPoints(sleva), _
CentimetersToPoints(sverhy), CentimetersToPoints(12), CentimetersToPoints(9)).Select
Selection.ShapeRange.TextFrame.TextRange.Select
Selection.Collapse
Selection.InlineShapes.AddPicture FileName:=path + v(i), LinkToFile:=False, _
SaveWithDocument:=True
ThisDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, CentimetersToPoints(sleva), _
CentimetersToPoints(sverhy +
, MillimetersToPoints(42), MillimetersToPoints(7)).Select
Selection.ShapeRange.TextFrame.TextRange.Text = podpis(v(i))
bln = True
bln1 = True
GoTo metka
End If
If bln = True Then
sleva = 2
ThisDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, CentimetersToPoints(sleva), _
CentimetersToPoints(sverhy), CentimetersToPoints(12), CentimetersToPoints(9)).Select
Selection.ShapeRange.TextFrame.TextRange.Select
Selection.Collapse
Selection.InlineShapes.AddPicture FileName:=path + v(i), LinkToFile:=False, _
SaveWithDocument:=True
ThisDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, CentimetersToPoints(sleva), _
CentimetersToPoints(sverhy +
, MillimetersToPoints(42), MillimetersToPoints(7)).Select
Selection.ShapeRange.TextFrame.TextRange.Text = podpis(v(i))
bln = False
End If
metka:
If bln1 = True Then
sverhy = sverhy + 10
bln1 = False
If sverhy = 21 Then
'не знаю как убрать ссылку объекта selection с надписи, поэтому
'методом н. т. сделал так
ActiveWindow.View.Type = wdNormalView
ActiveWindow.View.Type = wdPrintView
'вставка нового листа
Selection.InsertBreak Type:=wdPageBreak
'перемещение курсора на новый лист, иначе несмотря на св-во top=1 все равно
'addtextbox на уже 2 лист, где уже есть фотки
Selection.MoveLeft Unit:=wdCharacter, Count:=1
sverhy = 1
End If
End If
Next
End Sub