I need to be able to detect whether any shape selected intersects with any other shape in the selection. Regardless of whether the shape is a curve or text. Comes in handy just before cutting vinyl. Often times characters "overlap" each other so a warning needs to be thrown. In the image I have purposely moved an "f", within the artistic text, to intersect with another character. The macro errors at the line noted. Interesting to note is that sometimes when the text is converted to curves it becomes a group of shapes. Especially if a lot of text.
Sub DetectIntersects() Dim sr As ShapeRange Dim s1 As Shape, s2 As Shape Dim bFound As Boolean Optimization = True bFound = False Set sr = ActiveSelectionRange If sr.Count <> 1 Then MsgBox ("Select shapes first"): GoTo exit1 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 'ERROR HERE bFound = True Exit For End If End If Next s2 Next s1 If bFound Then MsgBox "CAUTION! Something Intersects!!!", _ vbCritical, "Check For Intersecting lines" If Not bFound Then MsgBox "Good", _ vbDefaultButton1, "Check For Intersecting lines" Optimization = False ActiveWindow.Refresh exit1: End Sub
Does an Artistic Text shape even have a DisplayCurve?
If I check in the Locals window when debugging, it shows "Nothing" for DisplayCurve for s1 and s2.
If I convert the text to Curves, then I can check for intersections of the DisplayCurves.
I gave the wrong code above. Below is the correct one. Which I thought came from you anyway. lol.
I thought I could just drop in code to combine or weld the text after it's converted but neither of those work (see bold).
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 'ActiveSelection.Combine or ActiveSelection.Weld 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 "CAUTION, Something Intersects!!!", vbCritical 'If bFound Then Call MarkIntersects If Not bFound Then MsgBox "File is good, Nothing Interects."End Sub