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
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
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
It doesn't work for Text, that is what the <> cdrTextShape means. That it telling it to exclude text shapes because they do not have a DisplayCurve.