Author Topic: Absolute Center of Sset  (Read 7361 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 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: 1882
Re: Absolute Center of Sset
« Reply #4 on: July 08, 2008, 10:46:18 AM »
Both methods don't work.

Atook

• Swamp Rat
• Posts: 1026
• 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: 1026
• 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: 1882
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

fixo

• Guest
Re: Absolute Center of Sset
« Reply #15 on: July 09, 2008, 01:06:31 AM »
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'~

• Guest
Re: Absolute Center of Sset
« Reply #16 on: July 09, 2008, 01:14:47 AM »

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

Bryco

• Water Moccasin
• Posts: 1882
Re: Absolute Center of Sset
« Reply #17 on: July 09, 2008, 01:30:34 AM »
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.
Quote
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

• Swamp Rat
• Posts: 1026
• AKA Tim
Re: Absolute Center of Sset
« Reply #18 on: July 09, 2008, 01:56:11 AM »
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.
« Last Edit: July 09, 2008, 02:02:58 AM by Atook »

• Guest
Re: Absolute Center of Sset
« Reply #19 on: July 09, 2008, 03:31:34 AM »

Quote
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

Code: [Select]
Sub MovefromMidPntofEntBB()
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
'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 #20 on: July 09, 2008, 03:40:21 AM »

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!

• Guest
Re: Absolute Center of Sset
« Reply #21 on: July 09, 2008, 03:51:52 AM »

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!

Bryco

• Water Moccasin
• Posts: 1882
Re: Absolute Center of Sset
« Reply #22 on: July 09, 2008, 05:08:30 AM »
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
Quote
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

• Guest
Re: Absolute Center of Sset
« Reply #23 on: July 09, 2008, 05:35:31 AM »

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

Code: [Select]
Sub LastTry()
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

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

• Guest
Re: Absolute Center of Sset
« Reply #24 on: July 09, 2008, 05:39:31 AM »

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

Thanks!

CR

• Guest
Re: Absolute Center of Sset
« Reply #25 on: July 09, 2008, 05:52:21 AM »

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

CR

Atook

• Swamp Rat
• Posts: 1026
• AKA Tim
Re: Absolute Center of Sset
« Reply #26 on: July 09, 2008, 10:26:10 AM »
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.

• Guest
Re: Absolute Center of Sset
« Reply #27 on: July 09, 2008, 01:40:56 PM »
Quote
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

• Guest
Re: Absolute Center of Sset
« Reply #28 on: July 09, 2008, 01:41:39 PM »

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

• Guest
Re: Absolute Center of Sset
« Reply #29 on: July 09, 2008, 03:34:10 PM »
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