Sub InsFilesFromFolder()
' Вставляет все .cdr файлы из указанной папки в конец документа,
' подписывая страницы именем вставленного файла.
' После запуска макроса нужно перейти в требуемую папку и обязательно указать один из файлов
saveUnit = ActiveDocument.Unit: ActiveDocument.Unit = cdrMillimeter
Call btnBrowse
Call iImportFile(cbFolder, iFileCount(cbFolder))
End Sub
Sub iImportFile(myPath As String, NumberFile As Integer)
' Помощник InsFilesFromFolder()
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim impopt As StructImportOptions
Dim iSpacePointer As Integer
Dim iPageName As String
Set impopt = CreateStructImportOptions
With impopt
.MaintainLayers = True
End With
Dim impflt As ImportFilter
Dim iFileName As String
Dim s1 As Shape
Dim iPageWidth As Double
Dim iPageHight As Double
iPageWidth = ActiveDocument.Pages(ActiveDocument.Pages.Count).SizeWidth
iPageHight = ActiveDocument.Pages(ActiveDocument.Pages.Count).SizeHeight
Dim p1 As Page
Set p1 = ActiveDocument.InsertPagesEx(1, False, ActiveDocument.Pages(ActiveDocument.Pages.Count).Index, iPageWidth, iPageHight)
Dim iFileCollection As Collection
Set iFileCollection = FilenamesCollection(myPath, ".cdr", 1)
If myFlag Then Set iFileCollection = FilenamesCollection(myPath, ".pdf", 1)
For i = 1 To iFileCollection.Count
Set impflt = ActiveLayer.ImportEx(iFileCollection.Item(i), cdrCDR, impopt)
impflt.Finish
Set s1 = ActiveShape
s1.Move 0#, 0.1005
iPageName = Mid(iFileCollection.Item(i), Len(myPath) + 1, Len(iFileCollection.Item(i)) - Len(myPath) - 4)
If Len(iPageName) > 30 Then
iPageName = Left(iPageName, 30)
End If
ActiveDocument.Pages.Item(i + 1).Name = iPageName
Set p1 = ActiveDocument.InsertPagesEx(1, False, ActiveDocument.Pages(ActiveDocument.Pages.Count).Index, iPageWidth, iPageHight)
Next i
ActiveDocument.Pages(ActiveDocument.Pages.Count).Delete
End Sub
Private Sub btnBrowse()
Dim s$, i%
On Error Resume Next
s = Application.CorelScriptTools.GetFileBox(, "Impot from...", 1, txPrefix, , cbFolder, "use this folder")
If s = sEmpty Then Exit Sub
cbFolder = XFilePath(s): chkDocFolder = False
If txPrefix = sEmpty Then txPrefix.Text = XFileName(s): _
i = InStrRev(txPrefix.Text, "."): If i > 0 Then txPrefix.Text = Left$(txPrefix.Text, i - 1)
End Sub
если что-то не подцепил - напишите