### Author Topic: Absolute Center of Sset  (Read 8756 times)

0 Members and 2 Guests are viewing this topic.

• Guest
##### Absolute Center of Sset
« on: July 06, 2008, 04:19:09 PM »

Is it possible to get the absolute midpoint of a selection set, despite how ever many entities are in it?

Thanks

#### fixo

• Guest
##### Re: Absolute Center of Sset
« Reply #1 on: July 06, 2008, 04:46:53 PM »
Hope this will get you started

Code: [Select]
Option Explicit

Sub GetSelectionCenter()

Dim xmin As Double, xmax As Double
Dim ymin As Double, ymax As Double
Dim i As Integer
Dim lp(0 To 2) As Double
Dim up(0 To 2) As Double

With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
End With

oSset.SelectOnScreen
ReDim xcoords(0 To (oSset.Count - 1) * 2) As Double
ReDim ycoords(0 To (oSset.Count - 1) * 2) As Double

For Each oEnt In oSset
Dim minExt As Variant
Dim maxExt As Variant
oEnt.GetBoundingBox minExt, maxExt
xcoords(i) = minExt(0): xcoords(i + 1) = maxExt(0)
ycoords(i) = minExt(1): ycoords(i + 1) = maxExt(1)
i = i + 1
Next
xmin = SortDesc(xcoords)(0): ymin = SortDesc(ycoords)(0)
xmax = SortAsc(xcoords)(0): ymax = SortAsc(ycoords)(0)
lp(0) = xmin: lp(1) = ymin: lp(2) = 0#
up(0) = xmax: up(1) = ymax: up(2) = 0#
Dim minPt As Variant
Dim maxPt As Variant
Dim cpt As Variant
Dim centPt(2) As Double
With ThisDrawing.Utility
minPt = .TranslateCoordinates(lp, acUCS, acWorld, False)
maxPt = .TranslateCoordinates(up, acUCS, acWorld, False)
centPt(0) = (minPt(0) + maxPt(0)) / 2: centPt(1) = (minPt(1) + maxPt(1)) / 2: centPt(2) = 0#
cpt = .TranslateCoordinates(centPt, acUCS, acWorld, False)
End With
'for visualization only:
oCirc.color = acRed
ZoomWindow minPt, maxPt
End Sub

Public Function SortAsc(SourceArr As Variant) As Variant

Dim Check As Boolean
Dim Elem As Double
Dim iCount As Integer

Check = False
Do Until Check
Check = True
For iCount = LBound(SourceArr) To UBound(SourceArr) - 1
If SourceArr(iCount) < SourceArr(iCount + 1) Then
Elem = SourceArr(iCount)
SourceArr(iCount) = SourceArr(iCount + 1)
SourceArr(iCount + 1) = Elem
Check = False
End If
Next
Loop

SortAsc = SourceArr

End Function

Public Function SortDesc(SourceArr As Variant) As Variant

Dim Check As Boolean
Dim Elem As Double
Dim iCount As Integer

Check = False
Do Until Check
Check = True
For iCount = LBound(SourceArr) To UBound(SourceArr) - 1
If SourceArr(iCount) > SourceArr(iCount + 1) Then
Elem = SourceArr(iCount)
SourceArr(iCount) = SourceArr(iCount + 1)
SourceArr(iCount + 1) = Elem
Check = False
End If
Next
Loop

SortDesc = SourceArr

End Function

~'J'~

• Guest
##### Re: Absolute Center of Sset
« Reply #2 on: July 08, 2008, 02:18:04 AM »

Fix,

I will need to look closer at this.
Likely run it with Locals on to see exactly what is going on.

I have something simial but not quite as involved

Thank you

I will take a look

#### rogue

• Guest
##### Re: Absolute Center of Sset
« Reply #3 on: July 08, 2008, 06:22:17 AM »
well, "Center" generally means circle - Im supposing you mean the middle of a polygon that encompasses all selected entities... in which case you'd need even more code, and more complexity, than the code that was already posted.

But if you are looking for a quick and dirty, here is a little Function that averages the x/ys of the bounding boxes
of the selection set passed to it...

'----------------------------------------------------

Function SsCenter(objSset As AcadSelectionSet) As Variant

Dim MinPoint, MaxPoint As Variant       ' used for BBox return call
Dim I As Long, objCount As Long         ' various counters
Dim retPoint(1) As Double               ' Function return XY of Center
Dim TotalX As Double, TotalY As Double  ' tally averages on the fly

' make sure something decent was passed as a param ....
If objSset Is Nothing Then Exit Function    ' make sure we have SelSet
objCount = objSset.Count
If objCount = 0 Then Exit Function          ' make sure there's something in the SelSet

' Loop thru and get the min/max of each entity
For I = 0 To objCount - 1  ' Loop thru and Grab bounding boxes
objSset.Item(I).GetBoundingBox MinPoint, MaxPoint
TotalX = TotalX + MinPoint(0) + MaxPoint(0)
TotalY = TotalY + MinPoint(1) + MaxPoint(1)
Next I

' generate a 2-index safearray of the x/y average
retPoint(0) = TotalX / (objCount * 2): retPoint(1) = TotalY / (objCount * 2)
' return it as a variant
SsCenter = retPoint

End Function

#### Bryco

• Water Moccasin
• Posts: 1883
##### Re: Absolute Center of Sset
« Reply #4 on: July 08, 2008, 10:46:18 AM »
Both methods don't work.

#### Atook

• Swamp Rat
• Posts: 1031
• AKA Tim
##### Re: Absolute Center of Sset
« Reply #5 on: July 08, 2008, 10:59:28 AM »
Both methods don't work.
Well that helps the task at hand!

Is it the definition of 'center' that's the problem, or code that doesn't run?

• Guest
##### Re: Absolute Center of Sset
« Reply #6 on: July 08, 2008, 02:36:05 PM »

I was looking for the absolute center of the entire selection set.

For example, say all of the entities (bounding box's) from the lowest left point to the upper most right point were

0,0 to 50,50

Then I would be looking to set a variable to pick on the point 25,25

Once I have that point grabbed, then I can position the entire sset to where I needs it to be.

So, I would like it to work, whether it is one entity or 15; I have tried and tried but still no luck.

I think it would make sense (if I knew a way) to get the lowest left points (x and y) of the closest bounding box to 0,0, and the upper most right point of the bounding box (x and y) farthest from 0,0, then divide those 2 points by 2 and that should give the needed answer.

The question is, how do I get those values?

Thanks

• Guest
##### Re: Absolute Center of Sset
« Reply #7 on: July 08, 2008, 03:16:51 PM »

Ahh, one last thing; I think that my method (verbally) would make sense but there is one to consider; that is, what if a bounding box's point were - (neg) 0,0 ?

I guess then, we would need to first check if a value is < then 0,0, then get the furthest point in the negative 0,0 direction as the starting point and still get the furthest point from 0,0 as the needed points to divide by 2.

Sset-Ent.bounding box LL + UR /2

Again, if someone has a method that can get those 4 points (x and y), I think I can do the rest.

#### Atook

• Swamp Rat
• Posts: 1031
• AKA Tim
##### Re: Absolute Center of Sset
« Reply #8 on: July 08, 2008, 05:56:24 PM »
The quick and dirty way I'd get those values looks something like..
Code: [Select]
Public Function ReturnMid(objSS As AcadSelectionSet) As Variant
Dim varMinBound As Variant
Dim varMaxBound As Variant
Dim minX As Double
Dim minY As Double
Dim maxX As Double
Dim maxY As Double

Set objEnt = objSS(0)
objEnt.GetBoundingBox varMinBound, varMaxBound
minX = varMinBound(0): minY = varMinBound(1)
maxX = varMaxBound(0): maxY = varMaxBound(1)
For Each objEnt In objSS
objEnt.GetBoundingBox varMinBound, varMaxBound
If varMinBound(0) < minX Then minX = varMinBound(0)
If varMinBound(1) < minY Then minY = varMinBound(1)
If varMaxBound(0) < maxX Then maxX = varMaxBound(0)
If varMaxBound(1) < maxY Then maxY = varMaxBound(1)
Next objEnt
'calculate midpt, have kettle call pot black, etc..
'???
'PROFIT!!
End Function

#### fixo

• Guest
##### Re: Absolute Center of Sset
« Reply #9 on: July 08, 2008, 11:07:58 PM »
Both methods don't work.

Can you to solve it?

~'J'~

• Guest
##### Re: Absolute Center of Sset
« Reply #10 on: July 08, 2008, 11:11:44 PM »

Atook.

I kind of see where you are going with this by setting the ent = to sset; that is a very good idea.
I took a stab at it but I am still not getting the result that I wanted.
Do you see where I am going wrong?

Code: [Select]
Sub MovefromMidPntofSsetBB()
Dim varMinBound As Variant
Dim varMaxBound As Variant
Dim minX As Double, maxX As Double
Dim minY As Double, maxY As Double

On Error Resume Next
ThisDrawing.SelectionSets.Item("GetEnt").Delete

objSS.SelectOnScreen

Set objEnt = objSS(0)
objEnt.GetBoundingBox varMinBound, varMaxBound
minX = varMinBound(0): maxX = varMaxBound(0)
minY = varMinBound(1): maxY = varMaxBound(1)
For Each objEnt In objSS
objEnt.GetBoundingBox varMinBound, varMaxBound
If varMinBound(0) < minX Then minX = varMinBound(0)
If varMinBound(1) < minY Then minY = varMinBound(1)
If varMaxBound(0) < maxX Then maxX = varMaxBound(0)
If varMaxBound(1) < maxY Then maxY = varMaxBound(1)
'Get midpt of Sset
Dim Midpnt(2) As Double
Midpnt(0) = (minX + maxX) / 2
Midpnt(1) = (minY + maxY) / 2
Dim MoveTopnt As Variant
MoveTopnt = ThisDrawing.Utility.GetPoint(, "Select Destination Point: ")
objEnt.Move Midpnt, MoveTopnt
Next objEnt

objSS.Delete

'Debug.Print "varMinBound(0) = " & varMinBound(0) & " / " & "varMaxBound(1) = " & varMaxBound(1)
'Debug.Print "minX = " & minX & " / " & "maxX = " & maxX
End Sub

• Guest
##### Re: Absolute Center of Sset
« Reply #11 on: July 08, 2008, 11:13:00 PM »

Yes Fixo,
I did try yours as well and noticed it did not work.
I think Atook just about has it.
I took a stab at it but I am still doing something wrong, just not quite sure what it is yet

• Guest
##### Re: Absolute Center of Sset
« Reply #12 on: July 08, 2008, 11:14:58 PM »

Also

I think i want to be saying
objSS.move

#### Bryco

• Water Moccasin
• Posts: 1883
##### Re: Absolute Center of Sset
« Reply #13 on: July 08, 2008, 11:35:18 PM »
For Each objEnt In objSS
objEnt.GetBoundingBox varMinBound, varMaxBound
If varMinBound(0) < minX Then minX = varMinBound(0)
If varMinBound(1) < minY Then minY = varMinBound(1)
If varMaxBound(0) > maxX Then maxX = varMaxBound(0)
If varMaxBound(1) > maxY Then maxY = varMaxBound(1)
Next objEnt
Dim cpt(2) As Double
cpt(0) = (minX + maxX) / 2
cpt(1) = (minY + maxY) / 2
ReturnMid = cpt

End Function
« Last Edit: July 08, 2008, 11:42:27 PM by Bryco »

• Guest
##### Re: Absolute Center of Sset
« Reply #14 on: July 08, 2008, 11:59:39 PM »

Well, I'm not entirely sure what Bryco is saying here.
I understand that you are calculating the midpoint but that is still not getting the entire sset.
At least not with any method I am trying?

Code: [Select]
Dim varMinBound As Variant
Dim varMaxBound As Variant
Dim minX As Double, maxX As Double
Dim minY As Double, maxY As Double

On Error Resume Next
ThisDrawing.SelectionSets.Item("GetEnt").Delete

objSS.SelectOnScreen

Set objEnt = objSS(0)
objEnt.GetBoundingBox varMinBound, varMaxBound
minX = varMinBound(0): maxX = varMaxBound(0)
minY = varMinBound(1): maxY = varMaxBound(1)

For Each objEnt In objSS
objEnt.GetBoundingBox varMinBound, varMaxBound
If varMinBound(0) < minX Then minX = varMinBound(0)
If varMinBound(1) < minY Then minY = varMinBound(1)
If varMaxBound(0) < maxX Then maxX = varMaxBound(0)
If varMaxBound(1) < maxY Then maxY = varMaxBound(1)
Next objEnt

Dim cpt(2) As Double
cpt(0) = (minX + maxX) / 2
cpt(1) = (minY + maxY) / 2
Midpnt = cpt

Dim MoveTopnt As Variant
MoveTopnt = ThisDrawing.Utility.GetPoint(, "Select Destination Point: ")
objSS.Move Midpnt, MoveTopnt

objSS.Delete