TheSwamp
Code Red => VB(A) => Topic started by: CadRover 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
CAD
-
Hope this will get you started
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'~
-
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
-
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
-
Both methods don't work.
-
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?
-
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
-
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
-
The quick and dirty way I'd get those values looks something like..
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
-
Both methods don't work.
Yes, you're right, my bad
Can you to solve it?
~'J'~
-
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
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
-
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
-
Also
I think i want to be saying
objSS.move
-
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
-
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?
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
-
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'~
-
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
-
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.
-
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. :)
-
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
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
-
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
-
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
-
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
-
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
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
-
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
-
Holy S**T!
It looks like it was working perfectly
CR
-
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.
-
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
-
This midnight coding has to end..
It has to enddddddddddddddd :)
-
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.
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