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

0 Members and 1 Guest 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 ExplicitSub GetSelectionCenter()     Dim oSset As AcadSelectionSet     Dim oEnt As AcadEntity     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          Set oSset = .Add("TestSet")          End With     oSset.SelectOnScreen     ReDim xcoords(0 To (oSset.Count - 1) * 2) As Double     ReDim ycoords(0 To (oSset.Count - 1) * 2) As DoubleFor 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 + 1Nextxmin = 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 VariantDim maxPt As VariantDim cpt As VariantDim centPt(2) As DoubleWith ThisDrawing.UtilityminPt = .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:Dim oCirc As AcadCircleSet oCirc = ThisDrawing.ModelSpace.AddCircle(cpt, 10)oCirc.color = acRedZoomWindow minPt, maxPtEnd SubPublic 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 = SourceArrEnd FunctionPublic 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 = SourceArrEnd 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: 1864
##### Re: Absolute Center of Sset
« Reply #4 on: July 08, 2008, 10:46:18 AM »
Both methods don't work.

#### Atook

• Swamp Rat
• Posts: 1000
• 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: 1000
• 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 objEnt As AcadEntity    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.

Yes, you're right, my bad
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 objEnt As AcadEntity Dim objSS As AcadSelectionSet 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 Set objSS = ThisDrawing.SelectionSets.Add("GetEnt") 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 = " & maxXEnd 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: 1864
##### 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 »

` Dim objEnt As AcadEntity Dim objSS As AcadSelectionSet 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 Set objSS = ThisDrawing.SelectionSets.Add("GetEnt") 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`