OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > Code Critique

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 26-08-2010, 11:58
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Smile find touching shapes

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

Code:
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
Reply With Quote
  #2  
Old 31-08-2010, 04:12
shark shark is offline
Senior Member
 
Join Date: Aug 2010
Location: Russia, Belgorod
Posts: 145
Default try this

Hello
Part of nesting macro ?
How about this code ...
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...

Last edited by shark; 31-08-2010 at 04:29.
Reply With Quote
  #3  
Old 31-08-2010, 10:03
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

Quote:
Originally Posted by shark View Post
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
Reply With Quote
  #4  
Old 01-09-2010, 08:20
shark shark is offline
Senior Member
 
Join Date: Aug 2010
Location: Russia, Belgorod
Posts: 145
Default

hi
by the way, pay your attention on this part of your code
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
Code:
    ...
    n = n + cps.count
    if n > 0 then goto endfunc
  next sp2
next sp1

endfunc:
getIntCount = n

Last edited by shark; 01-09-2010 at 14:46.
Reply With Quote
  #5  
Old 06-04-2012, 04:30
sulfur17
Guest
 
Posts: n/a
Default

shark, you way will not work with wire shapes (not closed), because
Code:
Set sItr = sChecked.Intersect(sr(cnt1), True, True)
will raise error or something (cant remember)
Reply With Quote
  #6  
Old 09-04-2012, 08:44
shark shark is offline
Senior Member
 
Join Date: Aug 2010
Location: Russia, Belgorod
Posts: 145
Default

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

Last edited by shark; 09-04-2012 at 09:01.
Reply With Quote
  #7  
Old 10-04-2012, 07:42
sulfur17
Guest
 
Posts: n/a
Default

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

Last edited by sulfur17; 10-04-2012 at 07:49.
Reply With Quote
  #8  
Old 17-04-2012, 09:28
sulfur17
Guest
 
Posts: n/a
Default

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
Reply With Quote
Reply


Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)
 
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is Off

Forum Jump

Similar Threads
Thread Thread Starter Forum Replies Last Post
Find bitmaps Wendy Hurst General 2 23-11-2007 15:40
FInd index of shapes grouped with text rubidoux CorelDRAW/Corel DESIGNER VBA 3 07-10-2007 23:00
Where to find logos? Alex FAQ 3 25-10-2005 09:00
Find only shapes with compound path zlatev CorelDRAW/Corel DESIGNER VBA 1 15-02-2005 08:05
How can I find shortest distance between two curves, shapes? Jab CorelDRAW/Corel DESIGNER VBA 3 22-12-2004 14:16


All times are GMT -5. The time now is 15:49.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.
Copyright © 2011, Oberonplace.com