can any make a macro that can import all cdr files from 1folder to 1 file?
Cdr files to be imported contain only a page, or at least the same number of pages?
All them should be imported on the same layer? On the same page or on different pages?
honestly i need solution for that. normally if i am working on a project then i have to work with almost 20-100 files in 1 project, lots of action has to apply on all files and after applying all the actions i export that to pdf and print them. i have 1 more question if you dont mind when i use macro to import files this makes much time then normal means when i am manually importing files ?
and what this test naming do in the macro ?
I do not understand why but I do not care too much about miss sorting...
Prior to import we can sort the M() array according to our wish. I will make a sorting function able to solve that. But what is strange is the fact that in case of numbers it sorts perfectly but considering numbers as strings... First what starts with 1 (independent of what is following), after that with 2 and so on.
In some minutes I will post such a function. Eventually I will integrate it in the code you need. With an option for string sorting, against numbers sorting...
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133
Sub btImport() Dim NumFolder As String, fso As Object, f As Object, fc As Object, f1 As Object, Fis As String Dim N As Variant, El As Variant, NrPag As Long, Latime As Double, Inaltime As Double Dim Calea As String, extension As String, Pag As Page, boolString As Boolean, boolNumber As Boolean Dim msgAns As VbMsgBoxResult, i As Long Calea = "G:\TEC\Corel\Test Import" extension = "cdr" 'Choosing the sorting type: msgAns = MsgBox("Would you use string sorting of file names?" & vbCrLf & _ " If yes, please click ""Yes""." & vbCrLf & _ " If you wont numbers sorting, click ""No"".", vbYesNo, "Sorting strings or numbers") If msgAns = vbYes Then boolString = True: boolNumber = False Else boolString = False: boolNumber = True End If Dim impopt As StructImportOptions Set impopt = CreateStructImportOptions With impopt .MaintainLayers = True With .ColorConversionOptions .SourceColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 (ECI),Dot Gain 20%" .TargetColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 (ECI),Dot Gain 15%" End With End With Dim impflt As ImportFilter Set fso = CreateObject("Scripting.FileSystemObject") NumFolder = CorelScriptTools.GetFolder(Calea, "Select the folder to import cdr files") If NumFolder = "" Then End Set f = fso.GetFolder(NumFolder) Set fc = f.Files For Each f1 In fc If UCase(Right(f1.Name, Len(extension) + 1)) = UCase("." & extension) Then Fis = Fis & f1.Name & "|" End If Next N = Split(Fis, "|") ReDim Preserve N(UBound(N) - 1) 'eliminating "|" from the end... 'Sort the array according to your wish: If boolString Then Dim M() As String ReDim M(1) For i = 0 To UBound(N) M(i) = N(i): ReDim Preserve M(i + 1) Debug.Print M(i) Next i ReDim Preserve M(UBound(M()) - 1) M() = ShellSortString(M) ElseIf boolNumber Then Dim M1() As Long ReDim M1(1) For i = 0 To UBound(N) M1(i) = Left(N(i), Len(N(i)) - 4): ReDim Preserve M1(i + 1) Next i ReDim Preserve M1(UBound(M1()) - 1) M1() = ShellSortLong(M1()) End If Stop Latime = ActivePage.SizeWidth: Inaltime = ActivePage.SizeHeight Application.Optimization = True For Each El In IIf(boolString, M(), M1()) If NrPag = 0 Then ActivePage.Name = El ActivePage.Layers("Layer 1").Activate Set impflt = ActivePage.Layers("Layer 1").ImportEx(NumFolder & "\" & IIf(boolString, El, El & ".cdr"), cdrCDR, impopt) impflt.Finish Else Set Pag = ActiveDocument.AddPagesEx(1, Latime, Inaltime) Pag.Name = El Set impflt = ActivePage.Layers("Layer 1").ImportEx(NumFolder & "\" & IIf(boolString, El, El & ".cdr"), cdrCDR, impopt) impflt.Finish End If NrPag = NrPag + 1 Next TestNaming Application.Optimization = False ActiveWindow.Refresh Application.Refresh End Sub Function ShellSortString(ArrayToSort() As String, Optional Descending As Boolean = False) Dim intFinal As Integer, intGap As Integer, intFlag As Integer Dim intCount As Integer, strHolder As String intFinal = UBound(ArrayToSort) intGap = CInt(intFinal / 2) Do While intGap <> 0 intFlag = 1 For intCount = 0 To intFinal - intGap If IIf(Descending, ArrayToSort(intCount) < ArrayToSort(intCount + intGap), _ ArrayToSort(intCount) > ArrayToSort(intCount + intGap)) Then strHolder = ArrayToSort(intCount) ArrayToSort(intCount) = ArrayToSort(intCount + intGap) ArrayToSort(intCount + intGap) = strHolder intFlag = 0 End If Next intCount If intFlag = 1 Then intGap = CInt(intGap / 2) End If Loop ShellSortString = ArrayToSort() End Function Function ShellSortLong(ArrayToSort() As Long, Optional Descending As Boolean = False) Dim intFinal As Integer, intGap As Integer, intFlag As Integer Dim intCount As Integer, strHolder As String intFinal = UBound(ArrayToSort) intGap = CInt(intFinal / 2) Do While intGap <> 0 intFlag = 1 For intCount = 0 To intFinal - intGap If IIf(Descending, ArrayToSort(intCount) < ArrayToSort(intCount + intGap), _ ArrayToSort(intCount) > ArrayToSort(intCount + intGap)) Then strHolder = ArrayToSort(intCount) ArrayToSort(intCount) = ArrayToSort(intCount + intGap) ArrayToSort(intCount + intGap) = strHolder intFlag = 0 End If Next intCount If intFlag = 1 Then intGap = CInt(intGap / 2) End If Loop ShellSortLong = ArrayToSort() End Function
If you choose 'numbers' but file names contain alpha numeric characters you will receive an error...
Don't you receive the message: "Would you use string sorting of file names?"... Clicking Yes you choose string, and with No you choose numbers...
You look to not understand too much VBA. That line call procedure of naming. Of course, I did not write it again. You must keep it from my previous post...
there is no option to click on yes or no its giving me
compile error sub or function not defined.
when i click on the run button its showing me this