Finding text that intersects the shape

[vavalexus]

Hi guys!

Spent all day for a simple task. Maybe if I were a VBA programmer it'd take me faster but unfortunately I'm not. So really looking forward for your help!
Here is the pic

I need to analyze all text for its intersections with a shape (if it touches the shape). If text intersects - say make it red (leave text inside shape untouched).
Since Shape.intersect(Text) also considers text inside shape as intersection it is no good.
What algorithm I have come to at the moment is:

• Find intersections with "Intersect" command (thus I will have selection of intersecting the shape text objects and text inside the shape)
• Create a copy of weld shape with previously found text objects (intersected and laying inside)
• Compare perimeter of the initial shape and weld shapes created in previous step. If perimeters are not equal than the text objects that formed that weld objects are intersected so i make a selection.

I guess it is overly complicated algorithm and if there are few hundred objects it will take much time for it to finish. Maybe there is better solution?

I have Corel X3.

My code:
Layer "Stands" - with shapes
Layer "Names" - with objects (text) that are compared with shapes in "Stands" for intersection
Layer "Weld" and "Intersections" - are temporary layers
Layer "Mistakes" - here I put all intersecting text copies
I will add later checking for duplicates in "Mistakes with use of IsOnShape

Sub Find_overlaps() ' find objects touching shape by comparing perimeters

Dim doc As Document

Dim IntSel As New ShapeRange
Dim WeldSel As New ShapeRange
Dim MisSel As New ShapeRange

Dim sSelection As Shape
Dim s As Shape
Dim WeldS As Shape
Dim sIntersect As Shape
Dim Tgt As Shape

Dim AllShapes As ShapeRange
Dim TargetShapes As ShapeRange

Dim InitPerimeter As Long
Dim TgtPerimeter As Long

Dim i As Integer


'Optimization = True
ActiveDocument.BeginCommandGroup "touching find"

Set TargetShapes = ActivePage.Layers.Item("Stands").Shapes.All
For Each Tgt In TargetShapes ' cycle initial shapes
Tgt.CreateSelection
Set sSelectionR = Nothing
Set WeldSel = Nothing
Set MisSel = Nothing
Set sSelection = ActiveShape
InitPerimeter = CorelScript.GetCurveLength()

Set AllShapes = ActivePage.Layers.Item("Name").Shapes.All
For i = 1 To AllShapes.Count
Set sIntersect = AllShapes(i).Intersect(sSelection, True, True) 'Intersect each shape with the orginal selected shape
If Not sIntersect Is Nothing Then ' objects eather intersect or are inside, so lets weld it to compare their perimeter to initial one (we filter out objects outside shape so they won't be weld in the next step)
IntSel.Add sIntersect
sIntersect.MoveToLayer ActivePage.Layers("Intersections")

Set WeldS = sSelection.Weld(AllShapes(i), True, True)
If Not WeldS Is Nothing Then ' we have weld objects so lets count their perimeter
TgtPerimeter = CorelScript.GetCurveLength()
WeldSel.Add WeldS
WeldS.MoveToLayer ActivePage.Layers("Weld")

If InitPerimeter <> TgtPerimeter Then
'MsgBox AllShapes(i).Name
MisSel.Add AllShapes(i)

End If
End If
End If

Next i
WeldSel.Delete
IntSel.Delete
MisSel.CreateSelection
MisSel.CopyToLayer ActivePage.Layers("Mistakes")
ActivePage.Layers.Item("Mistakes").Shapes.All.CreateSelection
ActiveSelection.Fill.ApplyUniformFill CreateCMYKColor(0, 100, 100, 0)
ActiveDocument.ClearSelection
Next Tgt

ActiveDocument.EndCommandGroup
'Optimization = False
ActiveWindow.Refresh
Application.Refresh

End Sub

[runflacruiser]

HI.
Check out this thread.
It works with shapes but is similar to waht you are attempting.

http://forum.oberonplace.com/showthread.php?t=7136

~John