this type of crop mark required of to any shape i create + on multiple shapes in 1 click to selected ones.
You can try this:
Sub crop_marks_shapes()Dim s1 As ShapeDim s2 As ShapeDim sr1 As ShapeRangeDim sr2 As New ShapeRangeDim cl_horiz As DoubleDim cl_vert As DoubleDim crop_length_target As DoubleDim line_width As Double crop_length_target = 0.25 line_width = 0.007 Optimization = True ActiveDocument.BeginCommandGroup "crop marks shapes" EventsEnabled = False On Error GoTo ErrHandler Set sr1 = ActiveSelectionRange.Shapes.All For Each s1 In sr1 If s1.SizeWidth / 2 < crop_length_target Then cl_horiz = s1.SizeWidth / 2 Else cl_horiz = crop_length_target End If If s1.SizeHeight / 2 < crop_length_target Then cl_vert = s1.SizeHeight / 2 Else cl_vert = crop_length_target End If Set s2 = ActiveLayer.CreateLineSegment(s1.LeftX, s1.TopY - cl_vert, s1.LeftX, s1.TopY) s2.Curve.SubPaths(1).AppendLineSegment s1.LeftX + cl_horiz, s1.TopY s2.Outline.Width = line_width s2.Name = "crop mark" sr2.Add s2 Set s2 = ActiveLayer.CreateLineSegment(s1.RightX - cl_horiz, s1.TopY, s1.RightX, s1.TopY) s2.Curve.SubPaths(1).AppendLineSegment s1.RightX, s1.TopY - cl_vert s2.Outline.Width = line_width s2.Name = "crop mark" sr2.Add s2 Set s2 = ActiveLayer.CreateLineSegment(s1.RightX, s1.BottomY + cl_vert, s1.RightX, s1.BottomY) s2.Curve.SubPaths(1).AppendLineSegment s1.RightX - cl_horiz, s1.BottomY s2.Outline.Width = line_width s2.Name = "crop mark" sr2.Add s2 Set s2 = ActiveLayer.CreateLineSegment(s1.LeftX + cl_horiz, s1.BottomY, s1.LeftX, s1.BottomY) s2.Curve.SubPaths(1).AppendLineSegment s1.LeftX, s1.BottomY + cl_vert s2.Outline.Width = line_width s2.Name = "crop mark" sr2.Add s2 Next s1 sr2.CreateSelectionExitSub: Optimization = False EventsEnabled = True Application.Refresh ActiveDocument.EndCommandGroup Exit SubErrHandler: MsgBox "Error occurred: " & Err.Description Resume ExitSubEnd Sub
You can change the values for length and line width to what you prefer.
When the macro finishes, the crop marks that were created are all selected.
Here is a different version that puts the crop marks completely on the outside of each shape. This is the style of crop mark that Myron showed in this thread.
This takes into account not just the thickness of the crop mark line, but also the line thickness, pen shape, etc. of the shape. It does that by duplicating the shape, then converting it to a bitmap (which is deleted after the crop marks have been created).
This version also allows an additional gap to optionally be added between the shape and the crop marks.
Sub crop_marks_shapes_full_outside()Dim s1 As ShapeDim s2 As ShapeDim s3 As ShapeDim sr1 As ShapeRangeDim sr2 As New ShapeRangeDim cl_horiz As DoubleDim cl_vert As DoubleDim crop_length_target As DoubleDim line_width As DoubleDim gap As DoubleDim total_offset As Double crop_length_target = 0.25 line_width = 0.05 gap = 0 total_offset = line_width / 2 + gap Optimization = True ActiveDocument.BeginCommandGroup "crop marks shapes" EventsEnabled = False On Error GoTo ErrHandler Set sr1 = ActiveSelectionRange.Shapes.All For Each s1 In sr1 Set s2 = s1.Duplicate(0, 0).ConvertToBitmap(1, , , , 299) If s2.SizeWidth / 2 < crop_length_target Then cl_horiz = s2.SizeWidth / 2 Else cl_horiz = crop_length_target End If If s2.SizeHeight / 2 < crop_length_target Then cl_vert = s2.SizeHeight / 2 Else cl_vert = crop_length_target End If Set s3 = ActiveLayer.CreateLineSegment(s2.LeftX - total_offset, s2.TopY + total_offset - cl_vert, s2.LeftX - total_offset, s2.TopY + total_offset) s3.Curve.SubPaths(1).AppendLineSegment s2.LeftX - total_offset + cl_horiz, s2.TopY + total_offset s3.Outline.Width = line_width s3.Name = "crop mark" sr2.Add s3 Set s3 = ActiveLayer.CreateLineSegment(s2.RightX + total_offset - cl_horiz, s2.TopY + total_offset, s2.RightX + total_offset, s2.TopY + total_offset) s3.Curve.SubPaths(1).AppendLineSegment s2.RightX + total_offset, s2.TopY + total_offset - cl_vert s3.Outline.Width = line_width s3.Name = "crop mark" sr2.Add s3 Set s3 = ActiveLayer.CreateLineSegment(s2.RightX + total_offset, s2.BottomY - total_offset + cl_vert, s2.RightX + total_offset, s2.BottomY - total_offset) s3.Curve.SubPaths(1).AppendLineSegment s2.RightX + total_offset - cl_horiz, s2.BottomY - total_offset s3.Outline.Width = line_width s3.Name = "crop mark" sr2.Add s3 Set s3 = ActiveLayer.CreateLineSegment(s2.LeftX - total_offset + cl_horiz, s2.BottomY - total_offset, s2.LeftX - total_offset, s2.BottomY - total_offset) s3.Curve.SubPaths(1).AppendLineSegment s2.LeftX - total_offset, s2.BottomY - total_offset + cl_vert s3.Outline.Width = line_width s3.Name = "crop mark" sr2.Add s3 s2.Delete Next s1 sr2.CreateSelectionExitSub: Optimization = False EventsEnabled = True Application.Refresh ActiveDocument.EndCommandGroup Exit SubErrHandler: MsgBox "Error occurred: " & Err.Description Resume ExitSubEnd Sub
.