find touching shapes

[runflacruiser]

HI.
Check it out.
This will find any touching shapes and select them.
Ideas, suggestions, comments welcome.
-John

Option Explicit

Sub findTouchingShapes3()

Dim s As Shape, s1 As Shape, s2 As Shape, sr As ShapeRange
Dim count As Long, totalShapesCnt As Long
1001:
totalShapesCnt = ActivePage.Shapes.count
Set s = ActiveSelection
Set sr = ActivePage.Shapes.FindShapes(Query:="@com.selected = false")
ActiveDocument.BeginCommandGroup "touching"
For Each s1 In sr
    For Each s2 In ActiveSelection.Shapes
        If getIntCount(s2, s1) > 0 Then
            s1.AddToSelection
            count = count + 1
            If count = totalShapesCnt * 10 Then Exit Sub
            GoTo 1001:
        End If
    Next s2
Next s1
ActiveDocument.EndCommandGroup
End Sub


Private Function getIntCount(sFirst As Shape, sSecond As Shape) As Long
Dim sp1 As SubPath, sp2 As SubPath
Dim cps As CrossPoints, cp As CrossPoint
Dim x As Double, y As Double, n As Long
n = 0
If sFirst.Type <> cdrCurveShape Then sFirst.ConvertToCurves
If sSecond.Type <> cdrCurveShape Then sSecond.ConvertToCurves
For Each sp1 In sFirst.Curve.SubPaths
    For Each sp2 In sSecond.Curve.SubPaths
        Set cps = sp1.GetIntersections(sp2)
        n = n + cps.count
    Next sp2
Next sp1
getIntCount = n
End Function

[shark]

Hello
Part of nesting macro ?
How about this code ...

Sub FindIntersects()
Dim sr As ShapeRange
Dim srNew As ShapeRange
Dim sItr As Shape
Dim sChecked As Shape
Dim cnt As Long
Dim cnt1 As Long
Dim found As Boolean
    Set sr = ActiveSelectionRange
    Set srNew = New ShapeRange
    If sr.Count < 2 Then Exit Sub
    cnt = 1
    Do While cnt <= sr.Count '- 1
        Set sChecked = sr(cnt): found = False
        For cnt1 = cnt + 1 To sr.Count
            Set sItr = sChecked.Intersect(sr(cnt1), True, True)
            If Not sItr Is Nothing Then
                srNew.Add sChecked
                srNew.Add sr(cnt1)
                sr.Remove cnt1 'sr.count - 1
                found = True
                sItr.Delete
                Exit For
            End If
        Next cnt1
        If Not found Then ' check excluded shapes
            For cnt1 = 1 To srNew.Count
                Set sItr = sChecked.Intersect(srNew(cnt1), True, True)
                If Not sItr Is Nothing Then
                    srNew.Add sChecked
                    sItr.Delete
                    Exit For
                End If
            Next cnt1
        End If
    'Next cnt
        cnt = cnt + 1
    Loop
    ActiveDocument.ClearSelection
    If srNew.Count = 0 Then
        MsgBox "No intersected shapes found"
    Else
        srNew.CreateSelection
    End If
End Sub

perhaps need some optimization...

[runflacruiser]

Originally Posted by shark

Hello
Part of nesting macro ?
How about this code ...

HI.
Naw...I just thought it was a cool challenge.
I noticed yours works differently. It finds all shapes in a selection that are touching. Interesting.

In my code if you select 1 shape, it will find, and select all other shapes that touch it.

A circuit board designer asked if it was possible because he wanted to highlight a particular circuit.

-John

[shark]

hi
by the way, pay your attention on this part of your code

function getIntCount ...
    ...
    n = n + cps.count
    ...
getIntCount = n ' getIntCount can be any value  from 0 to ...
end function

sub findTouchingShapes3
    ...
    if getIntCount(s2, s1) > 0 then
    ...
end

why calculate some cycles in getIntCount ?
if need positive result only
may be add following check

    ...
    n = n + cps.count
    if n > 0 then goto endfunc
  next sp2
next sp1

endfunc:
getIntCount = n

shark, you way will not work with wire shapes (not closed), because

Set sItr = sChecked.Intersect(sr(cnt1), True, True)

will raise error or something (cant remember)

[shark]

I have a working macro that uses this code and all it's works.
Macro finds touching shapes and groups them.

I have tried this code on 2 intersecting lines (i mean simple 2-point line tool) and it works wrong.
I use CorelDRAW X5 SP3
screenshot on google.docs

Plus, it works strange with grouped shapes (when sShape.Type = cdrGroupShape)
When I try you algorithm with grouped shapes - my Corel DRAW just throw out to the desktop