Author Topic: Absolute Center of Sset  (Read 6118 times)

0 Members and 1 Guest are viewing this topic.

CadRover

  • 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

CAD

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

  • 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

CADR

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: 996
  • 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?


CadRover

  • 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

CADR


CadRover

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

CADR

Atook

  • Swamp Rat
  • Posts: 996
  • 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'~

CadRover

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

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

  • 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

CADR

CadRover

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

CadRover

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