crop mark required of different type for x6 please help

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 Shape
    Dim s2 As Shape
    Dim sr1 As ShapeRange
    Dim sr2 As New ShapeRange
    Dim cl_horiz As Double
    Dim cl_vert As Double
    Dim crop_length_target As Double
    Dim 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.CreateSelection

    ExitSub:
        Optimization = False
        EventsEnabled = True
        Application.Refresh
        ActiveDocument.EndCommandGroup
        Exit Sub

    ErrHandler:
        MsgBox "Error occurred: " & Err.Description
        Resume ExitSub

    End 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 Shape
    Dim s2 As Shape
    Dim s3 As Shape
    Dim sr1 As ShapeRange
    Dim sr2 As New ShapeRange
    Dim cl_horiz As Double
    Dim cl_vert As Double
    Dim crop_length_target As Double
    Dim line_width As Double
    Dim gap As Double
    Dim 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.CreateSelection

    ExitSub:
        Optimization = False
        EventsEnabled = True
        Application.Refresh
        ActiveDocument.EndCommandGroup
        Exit Sub

    ErrHandler:
        MsgBox "Error occurred: " & Err.Description
        Resume ExitSub

    End Sub