Hi folks,
I've been plugging away at a couple little tasks. Years ago I had created a macro that created cut lines and bleeds for my work. Since that time I've learned so much more I'm doing a "clean room" implementation of it that I can share with others.
On the previous version of the macro I checked each shape against all the others in a selection and selectively trimmed away anything that wasn't needed. Loops and loops of checks.
I figured this time I could just use the Simplify function, once Steve Blosser showed me that I could call that via the "FrameWork" API in VBA.
The one thing I'm stuck on at the moment is that after I do the simplify, make shapes don't exist. Even if they are the only shapes on the layer and I re-select them after the simplify.
I can contour the first shape, but the rest of the references no longer exist.
From what I can see I can't automatically get the reference to the resulting shapes from the "Framework" call.
I would definitely appreciate it if someone could take a look at this and point out what I'm (probably obviously) missing?
On the page I set-up a number of overlapping basic shapes to test. I select them, then run the macro. Creating the contour will fail. If I comment out the "Framework..." line the script proceeds to the end.
Sub testSimplify() Dim bleedWidth As Double Dim targetLayer As Layer Dim workLayer As Layer Dim bleedRange As ShapeRange Dim dupRange As ShapeRange Dim workSh As Shape Dim tmpSh As Shape Dim origSel As Shape Dim conSh As Shape Dim cEff As Effect Dim targetLayerName As String Dim bleedCount As Long Dim conRange As ShapeRange Dim origRange As ShapeRange bleedWidth = 0.125 Set origRange = ActiveDocument.SelectionRange Set origSel = ActiveDocument.Selection Set dupRange = New ShapeRange If (origRange Is Nothing) Then Exit Sub End If If (origRange.Count < 1) Then Exit Sub End If If (targetLayerName = "") Then reqTargetLayerName = "Bleeds" End If targetLayerName = reqTargetLayerName & ".Working.XXX" Set workLayer = ActiveDocument.ActivePage.CreateLayer(targetLayerName) ' Create duplicates or cutable items of each shape we have For Each workSh In origRange.Shapes Set tmpSh = workSh.Duplicate tmpSh.MoveToLayer workLayer dupRange.Add tmpSh Next workSh ' Simplify the dupRange dupRange.CreateSelection FrameWork.Automation.InvokeItem ("7da36c72-627c-4782-b51a-01718a43551b") ' Now contour each shape For Each conSh In dupRange.Shapes MsgBox ("After simplifying there are now " & dupRange.Count & " duplicates left.") If (Not conSh Is Nothing) Then Set cEff = conSh.CreateContour(cdrContourOutside, bleedWidth, CornerType:=cdrContourCornerBevel) Set conRange = cEff.Separate bleedCount = bleedCount + 1 conRange.Shapes(1).Name = "Bleed-" & bleedCount conRange.Shapes(1).Fill.CopyAssign conSh.Fill End If Next conSh ' origSel.CreateSelectionEnd Sub
Sub testSimplify()
Dim bleedWidth As Double
Dim targetLayer As Layer
Dim workLayer As Layer
Dim bleedRange As ShapeRange
Dim dupRange As ShapeRange
Dim workSh As Shape
Dim tmpSh As Shape
Dim origSel As Shape
Dim conSh As Shape
Dim cEff As Effect
Dim targetLayerName As String
Dim bleedCount As Long
Dim conRange As ShapeRange
Dim origRange As ShapeRange
bleedWidth = 0.125
Set origRange = ActiveDocument.SelectionRange
Set origSel = ActiveDocument.Selection
Set dupRange = New ShapeRange
If (origRange Is Nothing) Then
Exit Sub
End If
If (origRange.Count < 1) Then
If (targetLayerName = "") Then
reqTargetLayerName = "Bleeds"
targetLayerName = reqTargetLayerName & ".Working.XXX"
Set workLayer = ActiveDocument.ActivePage.CreateLayer(targetLayerName)
' Create duplicates or cutable items of each shape we have
For Each workSh In origRange.Shapes
Set tmpSh = workSh.Duplicate
tmpSh.MoveToLayer workLayer
dupRange.Add tmpSh
Next workSh
' Simplify the dupRange
dupRange.CreateSelection
FrameWork.Automation.InvokeItem ("7da36c72-627c-4782-b51a-01718a43551b")
' Now contour each shape
For Each conSh In dupRange.Shapes
MsgBox ("After simplifying there are now " & dupRange.Count & " duplicates left.")
If (Not conSh Is Nothing) Then
Set cEff = conSh.CreateContour(cdrContourOutside, bleedWidth, CornerType:=cdrContourCornerBevel)
Set conRange = cEff.Separate
bleedCount = bleedCount + 1
conRange.Shapes(1).Name = "Bleed-" & bleedCount
conRange.Shapes(1).Fill.CopyAssign conSh.Fill
Next conSh
' origSel.CreateSelection
End Sub
Hi Jeff. I also use `Invoke` from time to time, and the main thing I’ve noticed is that I have to add a short delay after `Invoke`, otherwise it behaves unexpectedly. `MsgBox` works too, but a delay is enough. It’s as if `Invoke` requires a specific type of interruption before the next code can run.I use this code for the pause:
Function WaitFor(ByVal NumOfSeconds As Double)Dim SngSec As SingleSngSec = Timer + NumOfSeconds
Do While Timer < SngSec DoEvents Loop
End FunctionThen just use it in your code:
' Simplify the dupRange dupRange.CreateSelection
WaitFor 0.2 Set dupRange = ActiveSelectionRange ' Now contour each shape For Each conSh In dupRange.ShapesMartin.
Hi Martin,
Thank you for the code! I tried it out, but there must be something else going on that I haven't figured out yet.
On my machine it didn't seem the wait helped :( I set it for different amounts, incrementing up to 50 seconds and there will still the same error about "Referenced object no longer exists."
Or is it the fact that I'm putting a contour on the object actually replaces the object or alters the ShapeRange? It all seems little opaque to me!
That's really strange. I'm using Corel DRAW 2018 (v20). Did you reassign the newly created objects generated by the `invoke` command after the `wait` command?Set dupRange = ActiveSelectionRangeIt won't work without that. If you did, I'm not sure how else I can help. I tested this code and it works.I made a few changes because working with layers in your code didn't work for me. That's why the code just creates a new test layer.
Sub testSimplify() Dim bleedWidth As Double Dim targetLayer As Layer Dim workLayer As Layer Dim bleedRange As ShapeRange Dim dupRange As ShapeRange Dim workSh As Shape Dim tmpSh As Shape Dim origSel As Shape Dim conSh As Shape Dim cEff As Effect Dim bleedCount As Long Dim conRange As ShapeRange Dim origRange As ShapeRange bleedWidth = 0.125 Set origRange = ActiveDocument.SelectionRange Set origSel = ActiveDocument.Selection Set dupRange = New ShapeRange If (origRange Is Nothing) Then Exit Sub End If If (origRange.Count < 1) Then Exit Sub End If Set workLayer = ActiveDocument.ActivePage.CreateLayer("Layer_TEST") ' Create duplicates or cutable items of each shape we have For Each workSh In origRange.Shapes Set tmpSh = workSh.Duplicate tmpSh.MoveToLayer workLayer dupRange.Add tmpSh Next workSh ' Simplify the dupRange dupRange.CreateSelection FrameWork.Automation.InvokeItem ("7da36c72-627c-4782-b51a-01718a43551b") WaitFor 0.2 Set dupRange = ActiveSelectionRange MsgBox ("After simplifying there are now " & dupRange.Count & " duplicates left.") ' Now contour each shape For Each conSh In dupRange.Shapes If (Not conSh Is Nothing) Then Set cEff = conSh.CreateContour(cdrContourOutside, bleedWidth, CornerType:=cdrContourCornerBevel) Set conRange = cEff.Separate bleedCount = bleedCount + 1 conRange.Shapes(1).Name = "Bleed-" & bleedCount conRange.Shapes(1).Fill.CopyAssign conSh.Fill End If Next conSh origRange.CreateSelection End Sub Function WaitFor(ByVal NumOfSeconds As Double) Dim SngSec As Single SngSec = Timer + NumOfSeconds Do While Timer < SngSec DoEvents Loop End Function
Oh my gosh, you got it! I wasn't setting the dupRange back to the ActiveSelectionRange. Once I added that in your suggestion worked perfectly.
I'm maybe still a little confused why just getting all the shapes on the layer didn't work instead, but at this point I'm just happy to have a solution.
Thanks so much!
You are welcome, glad to help you.
Corel is so much fun that I’ve felt like pulling my hair out so many times—if I had any.Once you start playing around with it, you’ll notice some very strange behavior. You can also write it simply:
dupRange.CreateSelection FrameWork.Automation.InvokeItem ("7da36c72-627c-4782-b51a-01718a43551b") WaitFor 0.2 For Each conSh In ActiveSelectionRange
It will work, but as soon as you comment out the waitfor, watch which objects it processes :-) So waitfor is indispensable. Maybe someone here can explain better why and what’s happening. I haven’t looked into it because it’s enough for me that it works.You can also simplify this:For Each workSh In origRange.Shapes Set tmpSh = workSh.Duplicate tmpSh.MoveToLayer workLayer dupRange.Add tmpShNext workShto only:Set dupRange = origRange.DuplicatedupRange.MoveToLayer workLayer