Macro to Query ShapeRrange for intersecting lines?

Anyone suggest a code to tell me whether any of the objects selected have intersecting lines and if so pop up a message that says something to the effect "CAUTION: Intersecting lines"?

  • Myron, 

    This is a very simple approach to your question. It is just to give you something to build from. There are better ways to optimize the looping but I wanted to keep it simple. Also, if you have a shape that does not have a displaycurve such as text then this is going to error out.

    Sub DetectIntersects()
        Dim sr As ShapeRange
        Dim s1 As Shape, s2 As Shape
        Dim bFound As Boolean
        
        bFound = False
        Set sr = ActiveSelectionRange
        
        For Each s1 In sr.Shapes
            If bFound Then Exit For
            For Each s2 In sr.Shapes
                If Not s1 Is s2 Then
                    If s1.DisplayCurve.IntersectsWith(s2.DisplayCurve) Then
                        bFound = True
                        Exit For
                    End If
                End If
            Next s2
        Next s1
        
        If bFound Then MsgBox "Myron, Something Intersects!!!"
        If Not bFound Then MsgBox "Myron, Nothing Interects."
    End Sub
    

    Hope that gets you started, 

    -Shelby

    • Shelby, you're correct, it errors out on text and also on objects that are not converted to curves. I've tried every options I could think of but can't get it to check all shapes to include text. Sometimes when cutting vinyl two consecutive characters tend to overlap. Especially when kerning has been adjusted. Also when my weed lines are inserted between lines of text sometimes they appear to miss the text but the descending characters intersect. Just thought it would be nice to run a macro to double check for me.
      • Myron,

        As I said, it was just meant as a starting point to give you a direction. Here is a little more help. Again, this is not perfect it does not error checking etc. It will work with text now, and I added a loop to check to see if a character overlaps with another. Give it a shot and see if I missed anything.

        Sub DetectIntersects()
            Dim sr As ShapeRange, srText As ShapeRange
            Dim s1 As Shape, s2 As Shape, s3 As Shape, s4 As Shape
            Dim bDuplicated As Boolean, bFound As Boolean
            
            bFound = False
            
            Set sr = ActiveSelectionRange.Shapes.FindShapes() 'Find all the shapes inside groups, this will also return the group as a shape
            sr.RemoveRange sr.FindAnyOfType(cdrGroupShape, cdrGuidelineShape, cdrBitmapShape) 'Remove any groups, guidelines or Bitmaps
            
            For Each s1 In sr.Shapes
                bDuplicated = False
                If bFound Then Exit For
                
                ' If the shape is text, make a duplicate and convert the duplicate to curves
                If s1.Type = cdrTextShape Then
                    Set s1 = s1.Duplicate
                    s1.ConvertToCurves
                    bDuplicated = True
                End If
                
                'Loop each shape to see if it intersects with the current shape
                For Each s2 In sr.Shapes
                    If Not s1 Is s2 And s2.Type <> cdrTextShape Then
                        If s1.DisplayCurve.IntersectsWith(s2.DisplayCurve) Then
                            bFound = True
                            Exit For
                        End If
                    End If
                Next s2
                
                'If the shape was text we need to break it apart and see if any letters intersect
                If bDuplicated Then
                    Set srText = s1.BreakApartEx
                    For Each s3 In srText.Shapes
                        If bFound Then Exit For
                        
                        For Each s4 In srText.Shapes
                            If Not s3 Is s4 Then
                                If s3.DisplayCurve.IntersectsWith(s4.DisplayCurve) Then
                                    bFound = True
                                    Exit For
                                End If
                            End If
                        Next s4
                    Next s3
                    
                    srText.Delete
                End If
            Next s1
            
            If bFound Then MsgBox "Myron, Something Intersects!!!"
            If Not bFound Then MsgBox "Myron, Nothing Interects."
        End Sub
        

        -Shelby

        • Perfect!! Now I just need to adjust my weed line macro to scale down to 99.99% so they aren't actually touching the bounding box.
          Thanks again Shelby.
          • oops. Retract that last bit. Got problems. I'll see if I can work them out.
            • Just to let you know I was able to insert this code into our cut software. Now whenever you hit "plot" or "Plot Selected" it checks to ensure no lines intersect. This would have saved my but earlier today had a I implemented this into the program before cutting my vinyl.
              I had some vinyl to cut but only had enough on hand to do this one job. All I had to do was cut some text. Well, guess what I forgot to do? The text was script and I forgot to "weld" the text first! Customer will now have to wait until new vinyl comes in!
              • I was messing around with this recently and somehow messed it up. Replaced all my gibberish code with this but errors out. And after purposely kerning 1 text character over another it doesn't pick it up as an intersect. Thoughts