How would I do this?

Shelby Moore
over 1 year ago

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

Parents Reply
  • over 1 year ago in reply to Myron
    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
Children

© Corel Corporation. All rights reserved. The content herein is in the form of a personal web log ("Blog") or forum posting. As such, the views expressed in this site are those of the participants and do not necessarily reflect the views of Corel Corporation, or its affiliates and their respective officers, directors, employees and agents. Terms of Use / Privacy​ ​/ ​Cookies / Terms and Conditions / User Guidelines.