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
Myron said:text is converted to curves it becomes a group of shapes
if the shape is a group, then function DisplayCurve will throw an error
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
Myron said:Below is the correct one. Which I thought came from you anyway. lol.
That code does not look familiar to me at all.
I played around with this a little bit last week, and I agree that creating temporary duplicate shapes is probably the way to go with this.
For some stuff, you can get away with creating virtual shapes instead of real duplicates, but I don't know if ConvertToCurves can be used with virtual shapes.
What about after duplicating the text instead of converting to curve you incorporate code from this IndividualCharacters macro which creates a curve out of each character? I won't be able to sleep if I don't complete this. lol
Sub IndividualCharacters() Dim s As Shape Dim srSelection As ShapeRange Dim srStateBefore As ShapeRange, srStateAfter As ShapeRange Set srSelection = ActiveSelectionRange Set srStateBefore = ActivePage.FindShapes(Type:=cdrTextShape) Optimization = True ActiveDocument.BeginCommandGroup "Characters to Curves" EventsEnabled = False ActiveDocument.PreserveSelection = False ActiveDocument.SaveSettings 'Breaks Text into Line For Each s In srSelection If s.Type = cdrTextShape Then If s.Text.Type = cdrParagraphText Then s.Text.ConvertToArtistic If s.Text.Story.Lines.Count > 1 Then s.BreakApart End If Next s Set srStateAfter = ActivePage.FindShapes(Type:=cdrTextShape) srStateAfter.RemoveRange srStateBefore srSelection.AddRange srStateAfter Set srStateBefore = ActivePage.FindShapes(Type:=cdrTextShape) 'Breaks Text into Words For Each s In srSelection If s.Type = cdrTextShape Then If s.Text.Story.Words.Count > 1 Then s.BreakApart End If Next s Set srStateAfter = ActivePage.FindShapes(Type:=cdrTextShape) srStateAfter.RemoveRange srStateBefore srSelection.AddRange srStateAfter Set srStateBefore = ActivePage.FindShapes(Type:=cdrTextShape) 'Breaks Text into Characters For Each s In srSelection If s.Type = cdrTextShape Then s.BreakApart End If Next s Set srStateAfter = ActivePage.FindShapes(Type:=cdrTextShape) srStateAfter.RemoveRange srStateBefore srSelection.AddRange srStateAfter 'Converts Character to Curves For Each s In srSelection If s.Type = cdrTextShape Then s.ConvertToCurves End If Next s srSelection.CreateSelection 'srSelection.Group 'Call WeldWithExample ExitSub: ActiveDocument.RestoreSettings ActiveDocument.PreserveSelection = True EventsEnabled = True Optimization = False ActiveWindow.Refresh Application.Refresh ActiveDocument.EndCommandGroup Exit Sub
ErrHandler: MsgBox "Error occured: " & Err.Description Resume ExitSubEnd Sub