[CDR 2017-2021] обЪединить 70 кореловских файлов в один файл

[Realalex]

Без понятия. Несколько десятков файлов я печатал. Работает. От файлов же ещё зависит, не только от их количества

 

[lexter77]

Да просто открываете все файлы зараз а в настройках печати же есть:

Я вижу тут один недостаток — файлы все равно придется открывать!

 

[Realalex]

С шифтом же

 

[Akro]

Да просто открываете все файлы зараз а в настройках печати же есть:

Посмотреть вложение 146574

Вот спасибо то)

 

[КоньЕстДетей]

Не по теме:
Сейчас в фигме модно всё делать

Не по теме:
А что у вас входит в понятие "всё" , если не секрет? )

 

[izrukvruki]

Может лучше сделать скрипт - указываете папку, по одному все файлы в PDF... А потом объединить все pdf в один и его печатать... Либо воспользоваться советами из соседнего раздела и назначить горячую папку и из нее автоматом печатать pdf

 

[adrian_adrian]

Не говоря уже о том, что за 70 страничный документ в кореле можно на кол посадить дизайнера

для этого есть индиз ))

 

[iKoolk]

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

если что-то не подцепил - напишите

 

[dastin]

ахтойта?

Dim iSpacePointer As Integer
...
If myFlag Then Set iFileCollection = FilenamesCollection(myPath, ".pdf", 1)
...
chkDocFolder = False
...
If txPrefix
...
Set s1 = ActiveShape
s1.Move 0#, 0.1005
...
Это избранное из чего-то бОльшего с юзерформой?

 

[iKoolk]

Пардоньте, недовычистил. Просто при вызове с шифтом у меня пдф-ки вставляются, но человеку цорел нужен, я эту часть убрал, да не доубрал

 

[iKoolk]

Короче, прошу прощенья, если не работает, а все еще нужно, я более тщательно отредактирую макросы и перевыложу

 

[_MBK_]

Вы если код выкладываете, в движке есть специальные тэги для этого (сверху окошка ввода текста) А то код при вводе рассыпается, бывает.

 

[iKoolk]

Вы если код выкладываете, в движке есть специальные тэги для этого (сверху окошка ввода текста) А то код при вводе рассыпается, бывает.

спасибо. сделаю работу над ошибками и выложу то, что нужно так как нужно

 

[iKoolk]

Sub btnBrowse()
   Dim s$, i%
   On Error Resume Next
   s = Application.CorelScriptTools.GetFileBox("CDR Files (*.cdr)|*.cdr", "Impot from...", 0, 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


Function XFilePath$(ByVal FullName$)
   Dim i&: i = InStrRev(FullName, "\"): XFilePath = Left$(FullName, i)
   End Function

Function XFileName$(ByVal FullName$)
   Dim i&: i = InStrRev(FullName, "\"): XFileName = Mid$(FullName, i + 1)
   End Function

Function iFileCount(myPath As String)
    Set FSO = CreateObject("Scripting.FileSystemObject")
    iFileCount = FSO.GetFolder(myPath).Files.Count
    s1 = FSO.GetFolder(myPath).SubFolders.Count
    s2 = FSO.GetFolder(myPath).Size
 
End Function


Sub InsFilesFromFolder()
    saveUnit = ActiveDocument.Unit: ActiveDocument.Unit = cdrMillimeter
    Call btnBrowse
    Call iImportFile(cbFolder, iFileCount(cbFolder))
End Sub

Sub iImportFile(myPath As String, NumberFile As Integer)
    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)
    For i = 1 To iFileCollection.Count
            Set impflt = ActiveLayer.ImportEx(iFileCollection.Item(i), cdrCDR, impopt)
        impflt.Finish
        
        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

 

[iKoolk]

Вот. Остались лишние переменные в области определения, но это не страшно.