Coordinates extraction and comparison

[popovsky]

Get and compare numbers

I would really appreciate if you would help me out with this:

i have a couple of sheets with colums containing names and coordinates
of objects. as text.
something like this:
in column A : names of objects.
in column B : coordinates as a text field with the folowing
formatting:
A B
SEA 'coord x:4.50cm y:27.50cm w:21.12cm h:28.87cm index:2

(+some values can be missing.. for ex :SHIP coord x:11.50cm y:32.00cm
h:2.08cm index:40)


i need to compute the following :
for each object i gotta find out if it inside the coordinates of
another object.
Like this:
we take X value (lets call it x1) of one object and compare to other
object's values of X (lets call it x2) and X+W (lets call it XW).
if x2<x1<xw and y2<y1<yh (same thing for vertical) then the object is
inside and i need a msgbox saying : SHIP is inside SEA.

THANX. I really appreciate your help.

 

[keepITcool]

I hope you know a bit of vba..it may look a bit complex but
when broken down it's not that difficult.

Be aware that the permutations grow very fast...
100 objects.. 900 permuts
1000 objects .. 999000 permuts!

also note that the ObjID's in column A must be unique.
(otherwise use the rowNr of the object as key)

<VBG>

the strings are parsed in the LocParse function.
to create an array of coordinates.
(missing coord are added as .01)
pls review the wisdom of that

instead of constantly redimming arrays...
I like to store stuff in dictionaries

so i store all the coord's in 1 dictionary.
then i start comparing that dictionary against itself.
and the (keys) of the positive results are then stored
in another dictionary.

when done..I write the results to a range.



'Code requires a reference to "Microsoft scripting runtime"

Option Explicit

Const x = 1
Const y = 2
Const w = 3
Const h = 4

Sub CompareObjects()
Dim rngData As Range, rngDump As Range
Dim dicData As Scripting.Dictionary
Dim dicTrue As Scripting.Dictionary

Dim vItms As Variant
Dim vKeys As Variant
Dim i&, j&, n&

Set rngData = Range(Cells(2, 1), Cells(Rows.Count, _
1).End(xlUp))
Set dicData = GetData(rngData)
Set dicTrue = New Scripting.Dictionary

'Get data from dictionary
vItms = dicData.Items
vKeys = dicData.Keys

'Compare all permutations
For i = LBound(vItms) To UBound(vItms)
For j = LBound(vItms) To UBound(vItms)
If i <> j Then
If IsInside(vItms(i), vItms(j)) Then
dicTrue.Add vKeys(i) & vbTab & vKeys(j), Null
End If
End If
Next
Next
If dicTrue.Count = 0 Then
MsgBox "No objects inside other"
Else
Set rngDump = Application.InputBox( _
dicTrue.Count & " objects inside other" & vbLf & _
"Select a range to dump the results", Type:=8)
rngDump.Resize(dicTrue.Count) = _
Application.Transpose(dicTrue.Keys)
rngDump.Resize(dicTrue.Count).TextToColumns _
rngDump, , , , -1, 0, 0, 0, 0, 0
End If

End Sub

Function GetData(rData As Range) As Scripting.Dictionary
Dim d As Scripting.Dictionary
Dim rObjID As Range
Dim aCoord As Variant
'Note objectID's must be unique

Set d = New Scripting.Dictionary
d.CompareMode = BinaryCompare
For Each rObjID In rData.Columns(1).Cells
With rObjID
If Len(.Value) Then
If Not d.Exists(.Value) Then
aCoord = LocParse(.Cells(1, 2).Value)
d.Add .Value, aCoord
End If
End If
End With
Next
Set GetData = d
End Function

Function LocParse(ByVal sLoc$)
'splits a location string into an array
'of its components

Dim vaRes(1 To 5), n&, p1&, p2&, vFind
sLoc = LCase(sLoc & " ")
For Each vFind In Array("x:", "y:", "w:", "h:", "index:")
n = n + 1
p1 = InStr(1, sLoc, vFind)
If p1 Then
p1 = p1 + Len(vFind)
p2 = InStr(p1, sLoc, " ")
vaRes(n) = Val(Mid(sLoc, p1, p2 - p1))
Else
vaRes(n) = 0.01
End If
Next
LocParse = vaRes
End Function

Function IsInside(OuterC, InnerC) As Boolean
'Returns True if InnerC is fully within OuterC
'Input arguments must be coordinate arrays
If InnerC(x) >= OuterC(x) Then
If InnerC(y) >= OuterC(y) Then
If InnerC(x) + InnerC(w) <= OuterC(x) + OuterC(w) Then
If InnerC(y) + InnerC(h) <= OuterC(y) + OuterC(h) Then
IsInside = True
End If
End If
End If
End If
End Function






--
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam


popovsky wrote :

 

[popovsky]

I really appreciate your help ! you saved my project !
but i gotta a couple a dummie questions
what are the requirements for data, ranges, sheets and etc.? - i hav
to tell that information to other guys so that when they generate th
sheet there will be no conflicts or bugs.
about permutations - i think the number of them will not exceed 10
anyway - so no major problem with that.
unique objid - i think i will use row number, as you have suggested

P.S. It's really great to have the result range at last ( calculatin
all that manually is not an easy task), but actually i my task is t
get the the data telling me
If any two objects are on the same "big" object - two ships in same SE
and two Seas on the same continent
If it not that hard, could you plz add this feature, cuz after seein
your neat code i finally understood that i'm nothing in VBA..

THANX AGAIN !
You saved me dozens of hours trying to figure out how can this be done

 

[keepITcool]

I've done the hard part.

take your time to read thru the code and
understand what's happening.

then mail me some actual data.
and specify what changes you want to the code
or where it should be made more flexible.
(range selection/ uniqueness.. etc )

Cant promise an answer today. will try
email in signature below.. just add the @ and .

--
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam


popovsky wrote :

 

[NickHK]

popovsky,
Don't know if it's worth it, but you could use the Intersect API.
You get the intersecting area as a result, if that would be useful to you.

If you get the initial worksheet in a more friendly format, it would help
also.

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Declare Function IntersectRect Lib "user32" (lpDestRect As RECT, _
lpSrc1Rect As RECT, _
lpSrc2Rect As RECT) _
As Long

Dim rectTest(100) As RECT
Dim rectResult As RECT
Dim i As Long
Dim j As Long
Dim Overlaps As Long

'Create our rects
For i = 0 To 99
With rectTest(i)
.Left = (20 * Rnd) + 2
.Top = (10 * Rnd) + 2
.Right = (30 * Rnd) + 2
.Bottom = (40 * Rnd) + 2
End With
Next

'Compare each to all the others
For i = 0 To 99
For j = 0 To 99
'No need to compare to itself
If i <> j Then
If IntersectRect(rectResult, rectTest(i), rectTest(j)) <> False
Then
MsgBox "Rect " & i & " & rect " & j & " overlap."
End If
End If
Next
Next

NickHK