Problem: Retrieving pictures from a folder to resize and crop
I take pictures and download to my laptop. I then select 1 by one to resize and crop. I recorded a macro to resize and crop but can only do 1 at a time. I want to run a batch file that selects each picture and runs he resize and crop macro. I won't know the file names in advance since they will always be changing but will always be in the same folder.
I need help in figuring out how to writhe batch file.
Thank you.
-Don-
The general way of processing all files of a certain type is a folder is ...
Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Dim i As Integer Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder(" ........ " ) ' -- put the folder name between the quotes (or get its value from a textbox) 'Process all PNG files in that folder (change png to jpg or tif if appropriate) For Each objFile In objFolder.Files If LCase(Right(objFile.Name, 4)) = ".png" Then
do_some_code(objFile.Name) ' calls your code and passes the filename
End If
Next objFileEnd Sub
'Then you must isolate the important steps from your recorded macro and insert it in here ...
sub do_some_code(fileName)
'......... insert code to process your file -- you must delete the name of the file you recorded *and* its quotes, and replace it with the word fileName *without* adding the quotes back.
end sub
- - -
If in doubt, post the code of the macro you recorded and we'll try to sort you out.
Sub MULTIPLE_SLOTS_2() ' Recorded 9/24/2014 Dim impopt As StructImportOptions Set impopt = CreateStructImportOptions impopt.Mode = cdrImportFull Dim impflt As ImportFilter Set impflt = ActiveLayer.ImportEx("C:\Users\Don\Documents\Laser Etching\Camera\July 25 2014\101MSDCF\DSC05127.JPG", cdrJPEG, impopt) impflt.Finish Dim s1 As Shape Set s1 = ActiveShape s1.Move 1.532161, -12.333902 Dim grp1 As ShapeRange Set grp1 = s1.UngroupEx Windows.FindWindow("C:\Users\Don\Documents\Laser Etching\Human Tags\Camera Project\Location Template 8 Pack.cdr").ActiveView.ToFitAllObjects Dim crop1 As ShapeRange Set crop1 = grp1.CustomCommand("Crop", "CropRectArea", 2.76002, -11.546594, 21.01302, 8.774406) ActiveDocument.ReferencePoint = cdrCenter crop1.SetSize 1.13, 20.321 crop1.SetSize 1.13, 1.258 crop1.SetPosition 1.094, -1.386094 crop1.SetPosition 1.094, 10.5 Set impopt = CreateStructImportOptions impopt.Mode = cdrImportFull Set impflt = ActiveLayer.ImportEx("C:\Users\Don\Documents\Laser Etching\Camera\July 25 2014\101MSDCF\DSC05137.JPG", cdrJPEG, impopt) impflt.Finish Dim s2 As Shape Set s2 = ActiveShape s2.Move -9.06002, -12.519197 Dim grp2 As ShapeRange Set grp2 = s2.UngroupEx grp2.Rotate 270# Windows.FindWindow("C:\Users\Don\Documents\Laser Etching\Human Tags\Camera Project\Location Template 8 Pack.cdr").ActiveView.ToFitAllObjects Dim crop2 As ShapeRange Set crop2 = grp2.CustomCommand("Crop", "CropRectArea", -9.380343, -13.456791, 8.872657, 6.864209) crop2.SetSize 1.13, 20.321 crop2.SetSize 1.13, 1.258 crop2.SetPosition 2.494, -3.296291 crop2.SetPosition 2.494, 10.5End Sub
A picture is worth a thousand words.
I think I have this almost ready to try ... I'm just tidying up a few things so I stand a chance of explaining it.
OK, Let's try ... I've resaved your CDR file with the test macro in it. It should pop up a form when you open the CDR file.
I've set the source path as C:\Users\Don\Documents\Laser Etching\Ready but you can edit that if needed.
If you have at least 8 JPG files in that folder, the macro should crop them and place them, then display a Done message. You probably want to do something instead of displaying Done, but that should work for testing.
To explain how the macro works ...
Dim SourceFolder As String, SourceType As String, CDRtype As cdrFilterDim resizeHeight As DoubleDim cropWidth As Double, bottomCrop As Double, topCrop As DoubleDim firstX As Double, firstY As Double, stepX As Double
The above declares the variables I am going to use for all the layout parameters.
When the button is clicked, we process the code ... I'm starting by setting values into those variables ...
Private Sub CommandButton1_Click()
'Preset the constants for easy editing (dimensions are in inches) SourceFolder = TextBox1.Value SourceType = ".jpg" 'Include the dot, use lower case CDRtype = cdrJPG 'without quotes -- must be correct CDRfilter for file type resizeHeight = 1.969 cropWidth = 1.13 bottomCrop = 0.398 topCrop = 1.969 - 0.313 firstX = 0.529 firstY = 9.866 stepX = 1.4
And then we get to importing the files. Its the procedure I described a few posts back, but modified so that we count the imported files, so we know which frame to put it in later ...
Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Dim i As Integer 'Used to count the frame number i = 0 Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder(SourceFolder) 'Process all matching files in that folder (choose SourceType as above) For Each objFile In objFolder.Files If LCase(Right(objFile.Name, 4)) = SourceType Then i = i + 1 setInFrame objFile.Path, i ' processes the individual photo ActiveWindow.Refresh End If If i = 8 Then 'the page is full Exit For End If Next objFile
The above code only finds the filenames. You'll see the line setInFrame in the middle -- it calls a subroutine which performs the main import and cropping action -- we'll cover that later
At the end we check if we have reached the 8th file, to know when to stop. For the moment we will just pop up a message:
MsgBox "It's done"End Sub
In the button click code, we determined the filePath and counted the frameNumber -- which we pass to the subroutine ...
Sub setInFrame(filePath As String, frameNumber As Integer) Dim impflt As ImportFilter Dim posX As Double, posY As Double
Using code similar to the recorded macro we import the stated file, and rotate it ...
Set impflt = ActiveLayer.ImportEx(filePath, CDRtype) 'Import the file impflt.Finish Dim s1 As Shape Set s1 = ActiveShape s1.Rotate 270 'And rotate it
It will not import at the correct size for the frame, so we scale it ...
ActiveDocument.ReferencePoint = cdrCenter 'Make it correct height s1.Stretch resizeHeight / (s1.TopY - s1.BottomY)
To make the cropping easier, I'm temporarily moving the image to the bottom left of the page. That is not necessary, but it makes the crop calculations clearer.
s1.LeftX = 0 'Temporarily move to page origin to simplify crop calculation s1.BottomY = 0
Now to do the crop ...
Dim crop1 As ShapeRange 'Perform the crop Dim cropLeftX As Double, cropRightX As Double cropLeftX = (s1.RightX - cropWidth) / 2 cropRightX = cropLeftX + cropWidth Set crop1 = s1.CustomCommand("Crop", "CropRectArea", cropLeftX, bottomCrop, cropRightX, topCrop)
This is derived from your recorded macro, but with the numbers replaced by variables so that they can be more easily edited if necessary (in that section at the top of the code).
crop1.LeftX = firstX + (frameNumber - 1) * stepX 'move crop to its frame crop1.BottomY = firstY crop1.OrderToBack 'behind frame (in case it matters, delete if not required)
The image is now cropped, but it is still in the bottom left corner of the page. So this is the bit where we use the frameNumber to calculate where to move the cropped image ...
End Sub
That's an explanation of what should be happening, but mainly for information because its all in the macro in the resaved file ready for testing.
Thanks for all of this.
I am not doing something right. I created the ready file and put .jpg pictures in it.
I saved the location.....,cdr file you have at to p of the post. When in Corel I open that file and I just get an 8.5x11" blank worksheet.
You probably need to go to tools > options > workspace > VBA and make sure Delay Load VBA is off.
You should then see a popup message each time you open the file, asking to confirm that you want to run macros. The macro form will then be shown.
Thanks. I turned it off. Now when I select Location%20Template%208%20Pack%20Update.cdr
nothing happens. It does not open.
That is very weird. I retested it on my laptop and it works there too.
OK, here's the macro as a standalone file. You need to put it in the %AppData%\Corel\CorelDRAW Graphics Suite X7\Draw\GMS folder and restart CorelDraw. A form should appear.
Then you will need to open your original CDR template file (not the resaved one I gave you) and click on the button in the form.
The disadvantage with doing it this way is that the form will appear every time you start CorelDraw, which can be a nuisance. But it should let you test if it works, while we figure out why the file I previously gave you does not open properly.
My steps:
- open coreldraw
- file
-open
-selected Location%20Template%208%20Pack%20Update
It then just sits there in the directory. Waited 10 minutes
Harry,
I am using X4. Maybe that is why it did not work. I will update to X7
Sorry about the delay. I am working on upgrading