Topic: Absolute Center of Sset

[CadRover]

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

Thanks

CAD

[fixo]

Hope this will get you started

Code: [Select]

Option Explicit

Sub 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 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:
Dim oCirc As AcadCircle
Set oCirc = ThisDrawing.ModelSpace.AddCircle(cpt, 10)
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'~

[CadRover]

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

CADR

[rogue]

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]

Both methods don't work.

[Atook]

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?

[CadRover]

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

CADR

[CadRover]

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.

CADR

[Atook]

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]

Both methods don't work.

Yes, you're right, my bad
Can you to solve it?

~'J'~

[CadRover]

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?

CADR

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 = " & maxX
End Sub


[CadRover]

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

CADR

[CadRover]

Also

I think i want to be saying
objSS.move

[Bryco]

    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

[CadRover]

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 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


[fixo]

    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

I'm learning something new from you
every time, thanks again

~'J'~

[CadRover]

Yes, Fixo
That will get you the midpoints of each ent in the selection set; it still does not seem to address what I was originally hoping for.

I'm not even sure it can be done.

hmmmmm.....may be I need to change my selection method from selectonscreen to selectcrossing.

Not sure, I am stomped

CADR

[Bryco]

fixo, I didn't figure out why yours didn't work but you are sorting all the points which is not necessary.
rogue was finding an average, not always correct.
Atook took the correct and simple approach.
CadRover 

That will get you the midpoints of each ent in the selection set; it still does not seem to address what I was originally hoping for.

Perhaps if you try it, it may even work.

[Atook]

Except that my code had bugs in it that Bryco corrected by switching the last two '<'s with '>'s.

I think you've got everything you need, you just need to piece it together..

If not, then what exactly is the difference between what you're expecting and what's happening? You posted earlier a comment about viewing the mid-point in the immediate window. Put something together from what we've got, and a selectionset where you know the mid-point, and see where the difference is.

The problem may be in the mid-point calculation (there are multiple yet different 'correct' ways) or in your execution after you find the point and are manipulating the selectionset. We can help with either.

It's late and the beer was flowing tonight, I hope I make sense.

[CadRover]

Perhaps if you try it, it may even work.

Bryco,

I appreciate your help but I'm not sure why you are assuming I did not try it?
Did you see my last post? I did try your suggested code.

I placed the code in precisely how I thought it needed to be and it still did not work.
I just realized that I missed the > as well.

Again, here is my code in its entirety; I am not sure where it is wrong.

I am trying to grab every thing in the entire sset and move it from the midpnt
If that is what the code that you suggested is doing, then I apologize because I missed something.

I think that Tipo's code did not have values assigned to some variables.
I stepped through hit and some variables were coming up as 0.

Thanks again
CADR

Code: [Select]

Sub MovefromMidPntofEntBB()
 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
 'Debug.Print "varMinBound(0) = " & varMinBound(0) & " / " & "varMaxBound(1) = " & varMaxBound(1)
 'Debug.Print "minX = " & minX & " / " & "maxX = " & maxX
End Sub


[CadRover]

Atook

I absolutely did try for quite a while with the code that you and Byrco both supplied.
It wasn't hard to piece something together that works because I already had code that will do each entity one at a time.
The problem I am having still, in my efforts was that I can not get the midpnt of the entire sset and move it into place.
In theory, from the get go, I think I had the right idea; unfortunately I did not get the result I needed after about an hour of trying.

May be I will try again tomorrow.

I agree with you, it is late and I am beat

Thanks for the help!

CADR

[CadRover]

I'm sure if I play around with it more, I can eventually get the result that I am looking for

It is not that important, nothing pressing

Thanks!
CADR

[Bryco]

Well I was hoping you would test it with the addition of a point and then check to see if the point was correct.
As that is the nature of testing code, one thing at a time.
Here you have checked the code by adding
1) an On error resume confusion next statement
2) objSS.Move Midpnt, MoveTopnt

Well there isn't a move method for a selectionset,  and turning off the error handler would show you that.
You must cycle through the set
'objSS.Move cpt, MoveTopnt
   For Each objEnt In objSS
   objEnt.Move cpt, MoveTopnt
   Next

In fact the post

Yes, Fixo
That will get you the midpoints of each ent in the selection set; it still does not seem to address what I was originally hoping for.
I'm not even sure it can be done.

Told me you hadn't tested the code

[CadRover]

Hi Bryco,

WOW, I can see that I am not the only one burning the midnight oil

Yes, I see your point; I use the on error resume next as easy way way to get past the key not found "if" The Selection Set doesn't exists, if it does, I delete it, otherwise move on to adding it.
Probably not the best way to handle it but it seems to work for me.
You raise a good point though; that is, that if there is another error, it may get over looked,

I am generally pretty good at running through code with the locals.
Even more so lately

When I remarked about the midpoints, I saw that you did the division, that is how I surmised that you had gotten the midpoints

You see, I think you/we identified the problem I was having; that is that there is no move method for ssets, therefore, I was trying to be creative. The whole time I was seeing that the points were getting into the variables as I was stepping through the code in the locals, but it was the move method that I was fixated on.

OK, I see....
I do loop through ssets by entity but from what you are saying, it seems that each entity will be moved at once still once we have looped through each ent and it is assigned to the sset; is that correct?
Or will they be moved one at a time?
Let me take a look.
Thanks for the patience.

Bry,
Incidentally, in the meantime, I recalled that I had some older code around.
I this this method would work also? Or, a variation of?
It looks even simpler then what we have done.
After stepping through the code, it does look like all variables are being properly set, again, it was the move method I was struggling with.

Here, do you mind taking a look?
Tell me what you think.
The variables will be different because this is older code that I pieced together but the same idea

I Will also try the code and method that you just posted

Thank you

CADR

Code: [Select]

Sub LastTry()
 Dim Ent As AcadEntity
 Dim Sset As AcadSelectionSet
 Dim llpnt As Variant 'lower left point
 Dim urpnt As Variant 'upper right point
 Dim Midpnt(0 To 2) As Double
 
 With ThisDrawing.Utility
  llpnt = .GetPoint(, vbCrLf & "Select Lower Left Point: ")
  urpnt = .GetCorner(llpnt, vbCrLf & "Select Upper Right Point: ")
 End With
 
 On Error Resume Next 'I know, I know :)
 ThisDrawing.SelectionSets.Item("GetEnts").Delete
 
 Set Sset = ThisDrawing.SelectionSets.Add("GetEnts")
 Sset.Select acSelectionSetCrossing, llpnt, urpnt
 
 Midpnt(0) = (llpnt(0) + urpnt(0)) / 2
 Midpnt(1) = (llpnt(1) + urpnt(1)) / 2
 
 'Bry, i will need that loop here, most likely

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

  For Each Ent In Sset
   Ent.Move Midpnt, MoveTopnt
  Next
 End Sub


[CadRover]

Hey Bry
I just tried the code that I just posted with doing the loop the way you suggested; it looks like it worked perfectly,
I need to make sure that the absolute center is being grabbed but I think this did it.
I am not using thr bounding box method at all, as you have probably noticed.

This may actually be the way to go

Please give it a try

Thanks!

CR

[CadRover]

Holy S**T!
It looks like it was working perfectly

CR

[Atook]

Holy S**T!
It looks like it was working perfectly..

Don't you love it when that happens!

Congrats, I'm glad we could help.

[CadRover]

Don't you love it when that happens!

Yes,
I do ATook, especially when it happens when you didn't expect it to.
Next, time, I will rather get it at 8 at night, instead of 4am
Nonetheless, it seems to working well now.
Yes, thank you guys for all the assistance.

CR

[CadRover]

This midnight coding has to end..
It has to enddddddddddddddd

[CadRover]

Hey guys, this is certainly not rocket science by any stretch but with code like the above, I sometimes like to add something like this to the end, in the case that a user decides that they don't want to make that change.

Code: [Select]

ThisDrawing.Regen acActiveViewport
 
 If MsgBox("Are you sure that you want to move these entities?", vbYesNo) = vbYes Then
  Exit Sub
 Else
  ThisDrawing.SendCommand "undo" & vbCr & "1" & vbCr
  ThisDrawing.Regen acActiveViewport
 End If

I placed it right below the For Each Loop and before The End Sub

CR