In another thread Myron posted the following:
I have a macro that's been working fine for years, just trying to both streamline it and make the Registration marks a minimal of .5" from the printed shapes
I thought this would be a good chance for me to share my process on how I would go about coding this. So lets take it step by step.
This first step I normally do is decide on a name for my Sub. Since it looks like the end goal of these steps it to create the registration marks I decided on "CreateFCRegistrationMarks"
Sub CreateFCRegistrationMarks() End Sub
Now lets look at his first item. He is looking for a selection so we should first test that we have a selection and if we do not then message the user that they need to select something. To do this I define a ShapeRange set it to the ActiveSelectionRange and then count the number of shapes selected. If that number is zero I show a message to the user to please select something. I will often add a comment above my section of code that that reminds me what I am trying to code or explains what I am doing in that section of code.
Sub CreateFCRegistrationMarks() Dim srSelection As ShapeRange 'Selected shapes must remain on Layer 1 or moved at some point to Layer 1 Set srSelection = ActiveSelectionRange If srSelection.Shapes.Count = 0 Then MsgBox "Please select something.", , "FC Registration Marks": Exit Sub End Sub
The second item to create a layer and make sure it is set to not print.
Sub CreateFCRegistrationMarks() Dim srSelection As ShapeRange Dim lrCut As Layer 'Selected shapes must remain on Layer 1 or moved at some point to Layer 1 Set srSelection = ActiveSelectionRange If srSelection.Shapes.Count = 0 Then MsgBox "Please select something.", , "FC Registration Marks": Exit Sub 'Create a layer called Cut with print off Set lrCut = ActivePage.CreateLayer("Cut") lrCut.Printable = False End Sub
The third item is to create another layer.
Sub CreateFCRegistrationMarks() Dim srSelection As ShapeRange Dim lrCut As Layer, lrFC As Layer 'Selected shapes must remain on Layer 1 or moved at some point to Layer 1 Set srSelection = ActiveSelectionRange If srSelection.Shapes.Count = 0 Then MsgBox "Please select something.", , "FC Registration Marks": Exit Sub 'Create a layer called Cut with print off Set lrCut = ActivePage.CreateLayer("Cut") lrCut.Printable = False 'Create a layer called "FC RegistrationMark Layer1" Set lrFC = ActivePage.CreateLayer("FC RegistrationMark Layer1") End Sub
The fourth item is to create a rectangle on the "Cut" layer that is based off the selection, but instead of being the width and height of the selection we need to round up to the next whole number for the width and height. When I run into a requirement like this I will normally skip it for now because I want to get the code working then I can come back and add this. So for now let's just get it working based of the selection width and height. Then set the outline as the requirements request. To do this I added a line of code to get the bounding box of the selection. Then I use these values to create the rectangle direction on the Cut layer and not the ActiveLayer.
Sub CreateFCRegistrationMarks() Dim srSelection As ShapeRange Dim x As Double, y As Double, w As Double, h As Double Dim lrCut As Layer, lrFC As Layer Dim sRect As Shape 'Selected shapes must remain on Layer 1 or moved at some point to Layer 1 Set srSelection = ActiveSelectionRange If srSelection.Shapes.Count = 0 Then MsgBox "Please select something.", , "FC Registration Marks": Exit Sub srSelection.GetBoundingBox x, y, w, h 'Create a layer called Cut with print off Set lrCut = ActivePage.CreateLayer("Cut") lrCut.Printable = False 'Create a layer called "FC RegistrationMark Layer1" Set lrFC = ActivePage.CreateLayer("FC RegistrationMark Layer1") 'Create a Rectangle on Cut Layer around the selected ShapeRange, round h and w up, Outline color as 0,0,99,0 and thickness = hairline Set sRect = lrCut.CreateRectangle2(x, y, w, h) sRect.Outline.SetProperties 0.003, , CreateCMYKColor(0, 0, 99, 0) End Sub
The fifth item is to create he corner marks. There are a number of ways this could be done. Since the requirement says they want this to be a single shape I decided to just create a curve.
Sub CreateFCRegistrationMarks() Dim srSelection As ShapeRange Dim x As Double, y As Double, w As Double, h As Double Dim lrCut As Layer, lrFC As Layer Dim sRect As Shape, sCorners As Shape Dim crvCorners As Curve Dim sp As SubPath 'Selected shapes must remain on Layer 1 or moved at some point to Layer 1 Set srSelection = ActiveSelectionRange If srSelection.Shapes.Count = 0 Then MsgBox "Please select something.", , "FC Registration Marks": Exit Sub srSelection.GetBoundingBox x, y, w, h 'Create a layer called Cut with print off Set lrCut = ActivePage.CreateLayer("Cut") lrCut.Printable = False 'Create a layer called "FC RegistrationMark Layer1" Set lrFC = ActivePage.CreateLayer("FC RegistrationMark Layer1") 'Create a Rectangle on Cut Layer around the selected ShapeRange, round h and w up, Outline color as 0,0,99,0 and thickness = hairline Set sRect = lrCut.CreateRectangle2(x, y, w, h) sRect.Outline.SetProperties 0.003, , CreateCMYKColor(0, 0, 99, 0) 'Create corner marks around the rectangle each to be .75" x .75" and then combine marks to be rgb 0,0,0 and thickness = .02, combine marks to be named "FineCut_TomboGroup" 'and moved to layer "FC RegistrationMark Layer1" Set crvCorners = Application.CreateCurve(ActiveDocument) Set sp = crvCorners.CreateSubPath(x + 0.75, y) sp.AppendLineSegment x, y sp.AppendLineSegment x, y + 0.75 Set sp = crvCorners.CreateSubPath(x, y + h - 0.75) sp.AppendLineSegment x, y + h sp.AppendLineSegment x + 0.75, y + h Set sp = crvCorners.CreateSubPath(x + w - 0.75, y + h) sp.AppendLineSegment x + w, y + h sp.AppendLineSegment x + w, y + h - 0.75 Set sp = crvCorners.CreateSubPath(x + w, y + 0.75) sp.AppendLineSegment x + w, y sp.AppendLineSegment x + w - 0.75, y Set sCorners = lrFC.CreateCurve(crvCorners) sCorners.Outline.SetProperties 0.02, , CreateRGBColor(0, 0, 0) sCorners.Name = "FineCut_TomboGroup" End Sub
The final item is to set the "Cut" layer as Active. I also decided to clear the selection, this line could be removed if not wanted.
Sub CreateFCRegistrationMarks() Dim srSelection As ShapeRange Dim x As Double, y As Double, w As Double, h As Double Dim lrCut As Layer, lrFC As Layer Dim sRect As Shape, sCorners As Shape Dim crvCorners As Curve Dim sp As SubPath 'Selected shapes must remain on Layer 1 or moved at some point to Layer 1 Set srSelection = ActiveSelectionRange If srSelection.Shapes.Count = 0 Then MsgBox "Please select something.", , "FC Registration Marks": Exit Sub srSelection.GetBoundingBox x, y, w, h 'Create a layer called Cut with print off Set lrCut = ActivePage.CreateLayer("Cut") lrCut.Printable = False 'Create a layer called "FC RegistrationMark Layer1" Set lrFC = ActivePage.CreateLayer("FC RegistrationMark Layer1") 'Create a Rectangle on Cut Layer around the selected ShapeRange, round h and w up, Outline color as 0,0,99,0 and thickness = hairline Set sRect = lrCut.CreateRectangle2(x, y, w, h) sRect.Outline.SetProperties 0.003, , CreateCMYKColor(0, 0, 99, 0) 'Create corner marks around the rectangle each to be .75" x .75" and then combine marks to be rgb 0,0,0 and thickness = .02, combine marks to be named "FineCut_TomboGroup" 'and moved to layer "FC RegistrationMark Layer1" Set crvCorners = Application.CreateCurve(ActiveDocument) Set sp = crvCorners.CreateSubPath(x + 0.75, y) sp.AppendLineSegment x, y sp.AppendLineSegment x, y + 0.75 Set sp = crvCorners.CreateSubPath(x, y + h - 0.75) sp.AppendLineSegment x, y + h sp.AppendLineSegment x + 0.75, y + h Set sp = crvCorners.CreateSubPath(x + w - 0.75, y + h) sp.AppendLineSegment x + w, y + h sp.AppendLineSegment x + w, y + h - 0.75 Set sp = crvCorners.CreateSubPath(x + w, y + 0.75) sp.AppendLineSegment x + w, y sp.AppendLineSegment x + w - 0.75, y Set sCorners = lrFC.CreateCurve(crvCorners) sCorners.Outline.SetProperties 0.02, , CreateRGBColor(0, 0, 0) sCorners.Name = "FineCut_TomboGroup" 'ActiveLayer should be the "Cut" Layer ActiveDocument.ClearSelection lrCut.Activate End Sub
If I created three circles and give them a gray outline then run the code here is what it looks like so far.
The Layers are created, the rectangle and the corners are being created on the correct layers and the "Cut" layer is Active.I normally smile about now that it works. We are not done, we need to implement the requirement to round up the size.We can't use the Round function in VBA because if the number was 5.2 it would be rounded to 5. What we need is a Ceiling Function, but VBA doesn't have one so we will need to write our own.
Function Ceiling(dblNumber As Double) As Integer Ceiling = -Int(-dblNumber) End Function
Now that we have the ceiling function lets just add it to the code and try it.
Sub CreateFCRegistrationMarks() Dim srSelection As ShapeRange Dim x As Double, y As Double, w As Double, h As Double Dim lrCut As Layer, lrFC As Layer Dim sRect As Shape, sCorners As Shape Dim crvCorners As Curve Dim sp As SubPath 'Selected shapes must remain on Layer 1 or moved at some point to Layer 1 Set srSelection = ActiveSelectionRange If srSelection.Shapes.Count = 0 Then MsgBox "Please select something.", , "FC Registration Marks": Exit Sub srSelection.GetBoundingBox x, y, w, h 'Lets try with the Ceiling w = Ceiling(w) h = Ceiling(h) 'Create a layer called Cut with print off Set lrCut = ActivePage.CreateLayer("Cut") lrCut.Printable = False 'Create a layer called "FC RegistrationMark Layer1" Set lrFC = ActivePage.CreateLayer("FC RegistrationMark Layer1") 'Create a Rectangle on Cut Layer around the selected ShapeRange, round h and w up, Outline color as 0,0,99,0 and thickness = hairline Set sRect = lrCut.CreateRectangle2(x, y, w, h) sRect.Outline.SetProperties 0.003, , CreateCMYKColor(0, 0, 99, 0) 'Create corner marks around the rectangle each to be .75" x .75" and then combine marks to be rgb 0,0,0 and thickness = .02, combine marks to be named "FineCut_TomboGroup" 'and moved to layer "FC RegistrationMark Layer1" Set crvCorners = Application.CreateCurve(ActiveDocument) Set sp = crvCorners.CreateSubPath(x + 0.75, y) sp.AppendLineSegment x, y sp.AppendLineSegment x, y + 0.75 Set sp = crvCorners.CreateSubPath(x, y + h - 0.75) sp.AppendLineSegment x, y + h sp.AppendLineSegment x + 0.75, y + h Set sp = crvCorners.CreateSubPath(x + w - 0.75, y + h) sp.AppendLineSegment x + w, y + h sp.AppendLineSegment x + w, y + h - 0.75 Set sp = crvCorners.CreateSubPath(x + w, y + 0.75) sp.AppendLineSegment x + w, y sp.AppendLineSegment x + w - 0.75, y Set sCorners = lrFC.CreateCurve(crvCorners) sCorners.Outline.SetProperties 0.02, , CreateRGBColor(0, 0, 0) sCorners.Name = "FineCut_TomboGroup" 'ActiveLayer should be the "Cut" Layer ActiveDocument.ClearSelection lrCut.Activate End Sub Function Ceiling(dblNumber As Double) As Integer Ceiling = -Int(-dblNumber) End Function
And here is the output. The rectangle and corners have nicely rounded up to 4 inches, but they are no longer centered to the original selection.
There are again several ways we could fix this, we could align them. I decided I would just do the math. Here is the final code with an example of the output.
Sub CreateFCRegistrationMarks() Dim srSelection As ShapeRange Dim x As Double, y As Double, w As Double, h As Double Dim lrCut As Layer, lrFC As Layer Dim sRect As Shape, sCorners As Shape Dim crvCorners As Curve Dim sp As SubPath 'Selected shapes must remain on Layer 1 or moved at some point to Layer 1 Set srSelection = ActiveSelectionRange If srSelection.Shapes.Count = 0 Then MsgBox "Please select something.", , "FC Registration Marks": Exit Sub srSelection.GetBoundingBox x, y, w, h 'Fix the x, y, w, h to adjust for Rounding Up If Ceiling(w) - w > 0 Then x = x - ((Ceiling(w) - w) / 2) If Ceiling(h) - h > 0 Then y = y - ((Ceiling(h) - h) / 2) w = Ceiling(w) h = Ceiling(h) 'Create a layer called Cut with print off Set lrCut = ActivePage.CreateLayer("Cut") lrCut.Printable = False 'Create a layer called "FC RegistrationMark Layer1" Set lrFC = ActivePage.CreateLayer("FC RegistrationMark Layer1") 'Create a Rectangle on Cut Layer around the selected ShapeRange, round h and w up, Outline color as 0,0,99,0 and thickness = hairline Set sRect = lrCut.CreateRectangle2(x, y, w, h) sRect.Outline.SetProperties 0.003, , CreateCMYKColor(0, 0, 99, 0) 'Create corner marks around the rectangle each to be .75" x .75" and then combine marks to be rgb 0,0,0 and thickness = .02, combine marks to be named "FineCut_TomboGroup" 'and moved to layer "FC RegistrationMark Layer1" Set crvCorners = Application.CreateCurve(ActiveDocument) Set sp = crvCorners.CreateSubPath(x + 0.75, y) sp.AppendLineSegment x, y sp.AppendLineSegment x, y + 0.75 Set sp = crvCorners.CreateSubPath(x, y + h - 0.75) sp.AppendLineSegment x, y + h sp.AppendLineSegment x + 0.75, y + h Set sp = crvCorners.CreateSubPath(x + w - 0.75, y + h) sp.AppendLineSegment x + w, y + h sp.AppendLineSegment x + w, y + h - 0.75 Set sp = crvCorners.CreateSubPath(x + w, y + 0.75) sp.AppendLineSegment x + w, y sp.AppendLineSegment x + w - 0.75, y Set sCorners = lrFC.CreateCurve(crvCorners) sCorners.Outline.SetProperties 0.02, , CreateRGBColor(0, 0, 0) sCorners.Name = "FineCut_TomboGroup" 'ActiveLayer should be the "Cut" Layer ActiveDocument.ClearSelection lrCut.Activate End Sub Function Ceiling(dblNumber As Double) As Integer Ceiling = -Int(-dblNumber) End Function
Is the code perfect, nope. If you look at the second screenshot you will see that it has two layers named "Cut" and two named "FC RegistrationMark Layer1" because I forgot to clean this up before I ran the code again. The code doesn't check if the document already has these layers. It would be a nice improvement for it to check first before creating another layer with the same name.
How would you improve the code?
-Shelby
This the latest code with some tweaks. Works good for 1 group of shapes but not another on the same page. Not too worried about that part though. I can just manually create a rectangle on the the next ones, resize, move to cut layer, change color, copy paste the reg marks then use the shape tools to move the corners as needed.
Sub CreateFCRegistrationMarks() Dim srSelection As ShapeRange Dim x As Double, y As Double, w As Double, h As Double Dim lrCut As Layer, lrFC As Layer Dim sRect As Shape, sCorners As Shape Dim crvCorners As Curve Dim sp As SubPath ActiveDocument.BeginCommandGroup "CreateFCRegistrationMarks" 'Selected shapes must remain on Layer 1 or moved at some point to Layer 1 Set srSelection = ActiveSelectionRange If srSelection.Shapes.Count = 0 Then MsgBox "Please select something.", , "FC Registration Marks": Exit Sub srSelection.GetBoundingBox x, y, w, h 'Fix the x, y, w, h to adjust for Rounding Up If Ceiling(w) - w > 0 Then x = x + ((Ceiling(w) - w) / 2) If Ceiling(h) - h > 0 Then y = y - ((Ceiling(h) - h) / 2) w = Ceiling(w) h = Ceiling(h) 'Create a layer called Cut with print off If ActivePage.Layers.Find("Cut") Is Nothing Then Set lrCut = ActivePage.CreateLayer("Cut") lrCut.Printable = False End If 'Create a layer called "FC RegistrationMark Layer1" If ActivePage.Layers.Find("FC RegistrationMark Layer1") Is Nothing Then Set lrFC = ActivePage.CreateLayer("FC RegistrationMark Layer1") End If 'Create a Rectangle on Cut Layer around the selected ShapeRange, round h and w up, Outline color as 0,99,0,0 and thickness = hairline Set sRect = lrCut.CreateRectangle2(x - 0.625, y - 0.625, w + 1.25, h + 1.25) 'This works - creates a .625" clearance around sRect.Outline.SetProperties 0.003, , CreateCMYKColor(0, 99, 0, 0) sRect.GetBoundingBox x, y, w, h 'Create corner marks around the rectangle each to be .75" x .75" and then combine marks to be rgb 0,0,0 and thickness = .02, combine marks to be named "FineCut_TomboGroup" 'and moved to layer "FC RegistrationMark Layer1" Set crvCorners = Application.CreateCurve(ActiveDocument) Set sp = crvCorners.CreateSubPath(x + 0.75, y) sp.AppendLineSegment x, y sp.AppendLineSegment x, y + 0.75 Set sp = crvCorners.CreateSubPath(x, y + h - 0.75) sp.AppendLineSegment x, y + h sp.AppendLineSegment x + 0.75, y + h Set sp = crvCorners.CreateSubPath(x + w - 0.75, y + h) sp.AppendLineSegment x + w, y + h sp.AppendLineSegment x + w, y + h - 0.75 Set sp = crvCorners.CreateSubPath(x + w, y + 0.75) sp.AppendLineSegment x + w, y sp.AppendLineSegment x + w - 0.75, y Set sCorners = lrFC.CreateCurve(crvCorners) sCorners.Outline.SetProperties 0.02, , CreateRGBColor(0, 0, 0) sCorners.Name = "FineCut_TomboGroup" 'ActiveLayer should be the "Cut" Layer ActiveDocument.ClearSelection sRect.AddToSelection lrCut.Activate ActiveDocument.EndCommandGroupEnd Sub
Function Ceiling(dblNumber As Double) As Integer Ceiling = -Int(-dblNumber)End Function
In the code you show here, you are only "Setting" lrCut and lrFC if they don't already exist, and you need to create them.
If a layer already exists, then you will still need to "Set" thosee objects if you want to refer to them in your code.
So, instead of:
'Create a layer called Cut with print off If ActivePage.Layers.Find("Cut") Is Nothing Then Set lrCut = ActivePage.CreateLayer("Cut") lrCut.Printable = False End If
You might have:
'Define the Cut layer; create and set to non-printing if it does not already exist. If ActivePage.Layers.Find("Cut") Is Nothing Then Set lrCut = ActivePage.CreateLayer("Cut") lrCut.Printable = False Else Set lrCut = ActivePage.Layers.Find("Cut") End If
This is the latest. Your image is correct. When I run it the clearance on the sides is .5 not .625 like I want.
So somewhere I have a number wrong.
Option Explicit
Sub CreateFCRegistrationMarks() Dim srSelection As ShapeRange Dim x As Double, y As Double, w As Double, h As Double Dim lrCut As Layer, lrFC As Layer Dim sRect As Shape, sCorners As Shape Dim crvCorners As Curve Dim sp As SubPath ActiveDocument.BeginCommandGroup "CreateFCRegistrationMarks" Set srSelection = ActiveSelectionRange If srSelection.Shapes.Count = 0 Then MsgBox "Please select something.", , "FC Registration Marks": Exit Sub srSelection.GetBoundingBox x, y, w, h 'Fix the x, y, w, h to adjust for Rounding Up If Ceiling(w) - w > 0 Then x = x - ((Ceiling(w) - w) / 2) If Ceiling(h) - h > 0 Then y = y - ((Ceiling(h) - h) / 2) w = Ceiling(w) h = Ceiling(h) 'Create a layer called Cut with print off If ActivePage.Layers.Find("Cut") Is Nothing Then Set lrCut = ActivePage.CreateLayer("Cut") lrCut.Printable = False Else Set lrCut = ActivePage.Layers.Find("Cut") End If 'Create a layer called "FC RegistrationMark Layer1" If ActivePage.Layers.Find("FC RegistrationMark Layer1") Is Nothing Then Set lrFC = ActivePage.CreateLayer("FC RegistrationMark Layer1") lrCut.Printable = False Else Set lrFC = ActivePage.Layers.Find("FC RegistrationMark Layer1") End If Set sRect = lrCut.CreateRectangle2(x - 0.5, y - 0.5, w + 1, h + 1) sRect.Outline.SetProperties 0.003, , CreateCMYKColor(0, 99, 0, 0) sRect.GetBoundingBox x, y, w, h 'If sRect.SizeWidth < w + 1 Then 'sRect.SizeWidth = w + 0.5 'If sRect.SizeHeight < h + 1 Then 'sRect.SizeHeight = h + 0.5 'End If 'End If 'sRect.GetBoundingBox x, y, w, h 'Create corner marks around the rectangle each to be .75" x .75" and then combine marks to be rgb 0,0,0 and thickness = .02, combine marks to be named "FineCut_TomboGroup" 'and moved to layer "FC RegistrationMark Layer1" Set crvCorners = Application.CreateCurve(ActiveDocument) Set sp = crvCorners.CreateSubPath(x + 0.75, y) sp.AppendLineSegment x, y sp.AppendLineSegment x, y + 0.75 Set sp = crvCorners.CreateSubPath(x, y + h - 0.75) sp.AppendLineSegment x, y + h sp.AppendLineSegment x + 0.75, y + h Set sp = crvCorners.CreateSubPath(x + w - 0.75, y + h) sp.AppendLineSegment x + w, y + h sp.AppendLineSegment x + w, y + h - 0.75 Set sp = crvCorners.CreateSubPath(x + w, y + 0.75) sp.AppendLineSegment x + w, y sp.AppendLineSegment x + w - 0.75, y Set sCorners = lrFC.CreateCurve(crvCorners) sCorners.Outline.SetProperties 0.02, , CreateRGBColor(0, 0, 0) sCorners.Name = "FineCut_TomboGroup" 'ActiveLayer should be the "Cut" Layer ActiveDocument.ClearSelection sRect.AddToSelection lrCut.Activate ActiveDocument.EndCommandGroupEnd Sub
Myron said:When I run it the clearance on the sides is .5 not .625 like I want.
In code you posted last week, you had:
Set sRect = lrCut.CreateRectangle2(x - 0.625, y - 0.625, w + 1.25, h + 1.25) 'This works - creates a .625" clearance around
In code you posted today, you have:
Set sRect = lrCut.CreateRectangle2(x - 0.5, y - 0.5, w + 1, h + 1)
I've tried multiple numbers and can't quite get it right. Seems to be inconsistent with different size scenarios. What works for a whole number doesn't work for any irregular sizes i.e. ..629 etc. or shapes that end up being smaller produces an unnecessarily larger clearance.
Plus I don't want the size to round to the next 1/4". Either .5" or whole number would be ideal.
Seems in order to get the "pink" rectangle to always be centered the numbers have to be exactly half of each other. (1.25 / 2 = .625)
change Set sRect = lrCut.CreateRectangle2(x - 0.625, y - 0.625, w + 1.25, h + 1.25)
to Set sRect = lrCut.CreateRectangle2(x - 0.625, y - 0.625, w + 1, h + 1)
now the rect isn't centered. I think maybe I'm confusing the numbers.
Clearance wanted: .625
round number wanted: next nearest .5" or 1"
It sounds as though what you want is not what some of us might have understood.
The code as it stands right now:
If you want the created rectangle to be "rounded up to the nearest inch", then I think you would:
Your image from above has it correct.
All I need is for shapes @ 2.294"w x 8.629h"
rectangle h to be 2.294+.625" *2 which = 3.54 rounds to 4
rect w to be 8.629+.625 * 2 which = 9.879 rounds to 10
_________
Set sRect = lrCut.CreateRectangle2(x - 0.625, y - 0.625, w + 1.25, h + 1.25)
gets me 4.25 x 10.25
__________
gets me the desired 4 x 10 with at least a .625 clearance (Good)
Now try the same formula on the 10.5 x 38. Now you get 12 x 39 which gives only a .5 clearance on the width. Should be 39.5 which at a minimum would be .625 clearance. But I realize mathematically would not compute right.
OK, here's a version where it rounds up the size of the "final" rectangle, not the size of the selected objects.
Instead of calculating the size and position of that final rectangle, I'm creating it to exactly fit the selected objects, and then resizing it (with leeway and rounding up) while keeping it centered.
I'm using my own RoundUp function here, but this code would work just fine using Shelby's Ceiling function instead.
Sub CreateFCRegistrationMarks() Dim srSelection As ShapeRange Dim x As Double, y As Double, w As Double, h As Double Dim lrCut As Layer, lrFC As Layer Dim sRect As Shape, sCorners As Shape Dim crvCorners As Curve Dim sp As SubPath Const dblLeeway As Double = 0.625 ActiveDocument.BeginCommandGroup "CreateFCRegistrationMarks" 'Selected shapes must remain on Layer 1 or moved at some point to Layer 1 Set srSelection = ActiveSelectionRange If srSelection.Shapes.Count = 0 Then MsgBox "Please select something.", , "FC Registration Marks" Exit Sub End If 'Define the Cut layer; create and set to non-printing if it does not already exist. If ActivePage.Layers.Find("Cut") Is Nothing Then Set lrCut = ActivePage.CreateLayer("Cut") lrCut.Printable = False Else Set lrCut = ActivePage.Layers.Find("Cut") End If 'Create a layer called "FC RegistrationMark Layer1" If ActivePage.Layers.Find("FC RegistrationMark Layer1") Is Nothing Then Set lrFC = ActivePage.CreateLayer("FC RegistrationMark Layer1") Else Set lrFC = ActivePage.Layers.Find("FC RegistrationMark Layer1") End If 'get the wireframe bounding box of the selected shapes srSelection.GetBoundingBox x, y, w, h 'Create a Rectangle on Cut Layer around the selected ShapeRange, Outline color as 0,99,0,0 and thickness = hairline Set sRect = lrCut.CreateRectangle2(x, y, w, h) sRect.Outline.SetProperties 0.003, , CreateCMYKColor(0, 99, 0, 0) sRect.GetBoundingBox x, y, w, h 'Resize the rectangle to add leeway; round up each dimension to 0 decimal places; keep rectangle centered sRect.SetSizeEx sRect.CenterX, sRect.CenterY, JQ_RoundUp((w + 2 * dblLeeway), 0), JQ_RoundUp((h + 2 * dblLeeway), 0) 'Create corner marks around the rectangle each to be .75" x .75" and then combine marks to be rgb 0,0,0 and thickness = .02, combine marks to be named "FineCut_TomboGroup" 'and moved to layer "FC RegistrationMark Layer1" Set crvCorners = Application.CreateCurve(ActiveDocument) With sRect Set sp = crvCorners.CreateSubPath(.LeftX + 0.75, .BottomY) sp.AppendLineSegment .LeftX, .BottomY sp.AppendLineSegment .LeftX, .BottomY + 0.75 Set sp = crvCorners.CreateSubPath(.LeftX, .TopY - 0.75) sp.AppendLineSegment .LeftX, .TopY sp.AppendLineSegment .LeftX + 0.75, .TopY Set sp = crvCorners.CreateSubPath(.RightX - 0.75, .TopY) sp.AppendLineSegment .RightX, .TopY sp.AppendLineSegment .RightX, .TopY - 0.75 Set sp = crvCorners.CreateSubPath(.RightX, .BottomY + 0.75) sp.AppendLineSegment .RightX, .BottomY sp.AppendLineSegment .RightX - 0.75, .BottomY End With Set sCorners = lrFC.CreateCurve(crvCorners) sCorners.Outline.SetProperties 0.02, , CreateRGBColor(0, 0, 0) sCorners.Name = "FineCut_TomboGroup" ActiveDocument.ClearSelection sRect.AddToSelection 'ActiveLayer should be the "Cut" Layer lrCut.Activate ActiveDocument.EndCommandGroup End Sub Function JQ_RoundUp(Number As Double, NumDecPl As Long) As Double Dim dblTemp As Double On Error GoTo ErrHandler dblTemp = Number * 10 ^ NumDecPl If dblTemp > Int(dblTemp) Then JQ_RoundUp = (Int(dblTemp) + 1) / 10 ^ NumDecPl Else JQ_RoundUp = Number End If ExitFunc: Exit Function ErrHandler: MsgBox "Error occurred: " & Err.Description & vbCrLf & vbCrLf & "JQ_RoundUp()" Resume ExitFunc End Function
I like it! And can live with it as is but....
How about something like this to round to next .5" instead?
If rectangle decimal is > .5 then round to next whole number bigger
else leave it alone
So after factoring in the .625 Leeway and the rectangle ends up being 10.51 then round up to 11
but if it ends up being 10.49 round to 10.5
Look at a shape that is 18h x 24w the macro produces a 20x26 but a 19.5x25.5 would suffice.
Myron said:How about something like this to round to next .5" instead?
Here's a version where I've added a "round up to increment" function. That allows you to set the increment to 0.25, or 0.5, or 1, or whatever suits your needs.
Sub CreateFCRegistrationMarks() Dim srSelection As ShapeRange Dim x As Double, y As Double, w As Double, h As Double Dim lrCut As Layer, lrFC As Layer Dim sRect As Shape, sCorners As Shape Dim crvCorners As Curve Dim sp As SubPath Const dblLeeway As Double = 0.625 Const dblRoundUpIncrement As Double = 0.5 ActiveDocument.BeginCommandGroup "CreateFCRegistrationMarks" 'Selected shapes must remain on Layer 1 or moved at some point to Layer 1 Set srSelection = ActiveSelectionRange If srSelection.Shapes.Count = 0 Then MsgBox "Please select something.", , "FC Registration Marks" Exit Sub End If 'Define the Cut layer; create and set to non-printing if it does not already exist. If ActivePage.Layers.Find("Cut") Is Nothing Then Set lrCut = ActivePage.CreateLayer("Cut") lrCut.Printable = False Else Set lrCut = ActivePage.Layers.Find("Cut") End If 'Create a layer called "FC RegistrationMark Layer1" If ActivePage.Layers.Find("FC RegistrationMark Layer1") Is Nothing Then Set lrFC = ActivePage.CreateLayer("FC RegistrationMark Layer1") Else Set lrFC = ActivePage.Layers.Find("FC RegistrationMark Layer1") End If 'get the wireframe bounding box of the selected shapes srSelection.GetBoundingBox x, y, w, h 'Create a Rectangle on Cut Layer around the selected ShapeRange, Outline color as 0,99,0,0 and thickness = hairline Set sRect = lrCut.CreateRectangle2(x, y, w, h) sRect.Outline.SetProperties 0.003, , CreateCMYKColor(0, 99, 0, 0) sRect.GetBoundingBox x, y, w, h 'Resize the rectangle to add leeway; round up each dimension to 0 decimal places; keep rectangle centered sRect.SetSizeEx sRect.CenterX, sRect.CenterY, JQ_RoundUpToIncrement((w + 2 * dblLeeway), dblRoundUpIncrement), JQ_RoundUpToIncrement((h + 2 * dblLeeway), dblRoundUpIncrement) 'Create corner marks around the rectangle each to be .75" x .75" and then combine marks to be rgb 0,0,0 and thickness = .02, combine marks to be named "FineCut_TomboGroup" 'and moved to layer "FC RegistrationMark Layer1" Set crvCorners = Application.CreateCurve(ActiveDocument) With sRect Set sp = crvCorners.CreateSubPath(.LeftX + 0.75, .BottomY) sp.AppendLineSegment .LeftX, .BottomY sp.AppendLineSegment .LeftX, .BottomY + 0.75 Set sp = crvCorners.CreateSubPath(.LeftX, .TopY - 0.75) sp.AppendLineSegment .LeftX, .TopY sp.AppendLineSegment .LeftX + 0.75, .TopY Set sp = crvCorners.CreateSubPath(.RightX - 0.75, .TopY) sp.AppendLineSegment .RightX, .TopY sp.AppendLineSegment .RightX, .TopY - 0.75 Set sp = crvCorners.CreateSubPath(.RightX, .BottomY + 0.75) sp.AppendLineSegment .RightX, .BottomY sp.AppendLineSegment .RightX - 0.75, .BottomY End With Set sCorners = lrFC.CreateCurve(crvCorners) sCorners.Outline.SetProperties 0.02, , CreateRGBColor(0, 0, 0) sCorners.Name = "FineCut_TomboGroup" ActiveDocument.ClearSelection sRect.AddToSelection 'ActiveLayer should be the "Cut" Layer lrCut.Activate ActiveDocument.EndCommandGroup End Sub Function JQ_RoundUpToIncrement(Number As Double, IncrementSize As Double) As Double Dim dblTemp As Double On Error GoTo ErrHandler dblTemp = Number / IncrementSize If dblTemp > Int(dblTemp) Then JQ_RoundUpToIncrement = (Int(dblTemp) + 1) * IncrementSize Else JQ_RoundUpToIncrement = Number End If ExitFunc: Exit Function ErrHandler: MsgBox "Error occurred: " & Err.Description & vbCrLf & vbCrLf & "JQ_RoundUpToIncrement()" Resume ExitFunc End Function
That'll work. Thanks for all your help.