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?
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...
I think it's time to learn at least basic VBA since you post in this area...
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 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155
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 = IIf(boolString, Left(El, Len(El) - 4), 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 = IIf(boolString, Left(El, Len(El) - 4), El) Set impflt = ActivePage.Layers("Layer 1").ImportEx(NumFolder & "\" & IIf(boolString, El, El & ".cdr"), cdrCDR, impopt) impflt.Finish End If NrPag = NrPag + 1 Next PageNaming Application.Optimization = False ActiveWindow.Refresh Application.Refresh MsgBox "Ready...", , "Finish" 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 Sub PageNaming() Dim P As Page, Pag As Page, D As Document, i As Long, NrPag As Long, PName As String, IndexOK As Long Set D = ActiveDocument: NrPag = 2 For Each P In D.Pages If IndexOK >= P.Index Then GoTo Over If Left(P.Name, 4) <> "Page" Then PName = P.Name P.Name = PName & " - Page 1" For i = P.Index + 1 To D.Pages.Count If Left(D.Pages.Item(i).Name, 4) = "Page" Then D.Pages.Item(i).Name = PName & " - Page " & NrPag: IndexOK = i: NrPag = NrPag + 1 Else NrPag = 2: Exit For End If Next i End If Over: Next End Sub