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

    • amazing man i like this style of crop mark thank you soo much