ZoomCenter the active selection set

I would like to ZoomCenter the active selection set. The method I am thinking of would sum all the object coordinates (all X pos', all y pos',all z pos') and divide each by the number of objects in the selection set - basically averaging the positions and set that as the center. How would I "get" the position values of all the objects? - this seems like the long way around - any other suggestions?

Hey TIP

Now that is an interesting request.

This is a good question.

With a blockreference and some other entities, there is a boundingbox method.

You can get he midpoint of a bounding box, then you Zoom Center or Zoom (whatever)

Now, with a selection Set, I am not sure that there is such a method.

It is very late now but time permitting, i will take a look tomorrow.

I have some previosu code I could piece together for you "if" we can find the proper method.

Assuming Selection Set, would you want to manually slect the objects that you want in a selection set?

ML

1) Use GetBoundingBox method for each entity in selection set to retrieve min and max points of bounding box.

2) Sort coordinates and calculate LowerLeft and UpperRight points for all selection set.

3) Use ZoomWindow method.

Done...

Here is my old one, try this out

;;zw.lsp
;;zoom selection set by window

(vl-load-com)

(defun C:ZW  (/ a axss lp maxp minp points ss up)
 (setq	ss   (ssget)
axss (vla-get-activeselectionset
       (vla-get-activedocument
	 (vlax-get-acad-object))))
 (vlax-for a  axss
   (if	(not (vl-catch-all-error-p
       (vl-catch-all-apply
	 (function (lambda ()
		     (vla-getboundingbox a 'minp 'maxp))))))
     (setq points (append (list (vlax-safearray->list minp)
			 (vlax-safearray->list maxp))
		   points)
    )
     )
   )
 (setq	lp (car	(vl-sort points
		 (function (lambda (a b)
			     (and (< (car a) (car b))
				  (< (cadr a) (cadr b)))))))
up (car	(vl-sort points
		 (function (lambda (a b)
			     (and (> (car a) (car b))
				  (> (cadr a) (cadr b)))))))
)

 (vla-zoomwindow
   (vlax-get-acad-object)
     (vlax-3d-point lp)
      (vlax-3d-point up)
   )
 (princ)
 )

~'J'~

AS

I was thinking that would be the case, though it would be great if ACAD calculated all the entities in the sset for you; sort of an sset bounding box. That is essentially what this code would be doing, I suppose.

Once you have added all of the min and max extents of each bounding box, you could divide all coords in the X direction by 2 and the same for the Y coords; then

mdpnt = x +y/2

I think that would work well.

Oh yes, that is what tip was suggesting.

I have code where I did get the midpnt with this method but I did it in VBA.

I would have to try what AS has done in LISP.

ML

thank you gentlemen(?),

I am using VBA to do this - First I'm going to try ASMI's bounding box method w/ zoom window. WHEN I get stuck I'll be back! Would like to see any VBA alts you have though - appreciate it.

thanks again

Hi Tip

I was not sure if you preferred VBA or LISP

I am primarily a VB(A) programmer; I know very little LISP.

I wanted to see if the code that AS supplied for you would work for you first. If it does, we can easily load and run it with an ACAD menu macro

As far as VBA, I have bits and pieces that I could string together, such as the selection Set and getting the midpoint of a bounding box.

However, I would have to work it out, how to add them all up and get the midpnt.

It would be a cool piece of code to have

ML

Tip

Have you started it?

Anything you can post?

Thanks

ML

Oh man - thanks for the vote of confidence but I code about like glass flows being a newbee and all. No idea what I'm doing - self teaching here. I know what a method is, vaguely know how to iterate through the selection set /object group, sorting the coords and doing the math - easy, zoom easy but Days for me.....

Hey Tip

That's cool

I remember when I was starting with VBA about 4 yrs ago, it was not easy for me to get and there is still a ways to go.

To me, programming is like learning a musical instrument, you can get very good on it but you can never be done learning.

So, we have to be satisfied with where we are and what knowledge we have right now. Just the fact that you want to learn is a great start.

Well, let's see...

For a newbie, in my opinion, I would think learning to loop through a collection of objects is a great start. How and where to access collections.

Understanding why we need to declare variables; then setting a reference to the object, using those variables.

Once you get start understanding all that, then I would move into Ssets and filtering for entities in an sset and getting/manipulating points; as they are a little more advanced then just looping through a collection of objects.

So the code that you are asking for is certainly nor something that I would expect a beginner to bang out.

Tip, if you don't mind, I'd like to send you something, via a pvt message, it may help you understand some basics.

As far as this code, did you try The LISP version? Did it work?

Do you know how to load and run The LISP routine?

or do would you still prefer it in VBA?

ML

thank you gentlemen(?),

I am using VBA to do this - First I'm going to try ASMI's bounding box method w/ zoom window. WHEN I get stuck I'll be back! Would like to see any VBA alts you have though - appreciate it.

thanks again

Okay, here is the same thing but on VBA

Just select objects on screen to test it

Option Explicit

Sub ZoomWindowSet()

    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
With ThisDrawing.Utility
minPt = .TranslateCoordinates(lp, acUCS, acWorld, False)
maxPt = .TranslateCoordinates(up, acUCS, acWorld, False)
End With

ZoomWindow lp, up

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

I was close

I'm just not sure how to add all of the bounding boxes together

If anyone can help me complete this code, I would appreciate that.

It likely will require a function of some sort.

As this code stands; if you select any entity, one at a time,

the midpnt of the entity will be selected, then you will be prompted for the point that you'd like to move the entity to.

This would be good if you need to grab the center point of several entities and move them to a specific destination in the drawing.

If I get the final piece, then this code can easily be modified to get the midpnt of the total entities in one shot.

ML

Sub GetMidPntofEntBB()
Dim Ent As AcadEntity
Dim Sset As AcadSelectionSet
Dim minExt As Variant
Dim maxExt As Variant
Dim Midpnt(0 To 2) As Double
Dim MoveTopnt As Variant

On Error Resume Next 'If selection set exists, then delete it; otherwise move on
ThisDrawing.SelectionSets.Item("GetEnts").Delete

Set Sset = ThisDrawing.SelectionSets.Add("GetEnts")
Sset.SelectOnScreen


For Each Ent In Sset
  Ent.GetBoundingBox minExt, maxExt
 'Calculate the midpnt of the entity's Bounding Box
  Midpnt(0) = (minExt(0) + maxExt(0)) / 2
  Midpnt(1) = (minExt(1) + maxExt(1)) / 2
  Midpnt(2) = (minExt(2) + maxExt(2)) / 2
  Ent.Highlight True
  MoveTopnt = ThisDrawing.Utility.GetPoint(, "Select Destination Point: ")
  Ent.Move Midpnt, MoveTopnt
Next Ent

Sset.Delete
End Sub

Gentlemen, Thanks for your help. Here is what I ended up with.

Sub Center_ActiveSelectionSet()

Dim sset As AcadSelectionSet

Dim Entity As AcadEntity

Dim minExt As Variant

Dim maxExt As Variant

Dim LLExt(0 To 2) As Double

Dim URExt(0 To 2) As Double

Set sset = ThisDrawing.ActiveSelectionSet

For Each Entity In ThisDrawing.ActiveSelectionSet

Entity.GetBoundingBox minExt, maxExt

'iterate through bounding boxes and determine extremes

'Lower left comparisons >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

If LLExt(0)

LLExt(0) = LLExt(0)

Else

LLExt(0) = minExt(0)

End If

If LLExt(1)

LLExt(1) = LLExt(1)

Else

LLExt(1) = minExt(1)

End If

If LLExt(2) >= minExt(2) Then

LLExt(2) = LLExt(2)

Else

LLExt(2) = minExt(2)

End If

'Upper right comparisons >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

If URExt(0) >= minExt(0) Then

URExt(0) = URExt(0)

Else

URExt(0) = maxExt(0)

End If

If URExt(1) >= minExt(1) Then

URExt(1) = URExt(1)

Else

URExt(1) = maxExt(1)

End If

If URExt(2) >= minExt(2) Then

URExt(2) = URExt(2)

Else

URExt(2) = maxExt(2)

End If

Next Entity

'zoomwindow the active selection set

ThisDrawing.Application.ZoomWindow LLExt, URExt

End Sub

No rigorous trials but seems to be working!

Thanks again,

Hi Tip

Definitely closer to what I was getting at, in my above example, but not quite what I would like to use it for.

I was trying to figure out how to get all of the bounding boxes and sort of calculate them together but there is no method (that I know of) for looping through entity bounding boxes. That also would no work well because, what if bounding boxes over lapped.

So, that was a good idea to go for the most lower left and most upper right points of bounding boxes in the selection set. I did not think of that.

I would like to select all my entities, assign to a selection set, then grab the midpoint of the entire selection set. i is not of an immediate need for me, but now that I've seen your post, I think I will be able to work that out.

Also, with your code, you are grabbing the active selection set.

Have you considered what to do if there is no selection set in the drawing?

I think it would be better to create your selection set, then use a selection method, I would likely use select on screen for this one, then I would delete the selection set before exiting the sub.

If it works for you, that is great!

If you would like any further assistance, give me a holler

ML

Trent,

Give this a shot.

This may work for you as well.

May be a little bit of overkill but I try to always go safe then sorry

ML

Sub Move_Sset_Mid_Pt_To_Dest()
Dim ent As AcadEntity
Dim Sset As AcadSelectionSet
Dim llpnt As Variant 'lower left point
Dim urpnt As Variant 'upper right point

'Getpoints
With ThisDrawing.Utility
 llpnt = .GetPoint(, vbCrLf & "Select Lower Left Point: ")
 urpnt = .GetCorner(llpnt, vbCrLf & "Select Upper Right Point: ")
End With

On Error Resume Next
ThisDrawing.SelectionSets.Item("GetEnts").Delete

Set Sset = ThisDrawing.SelectionSets.Add("GetEnts")
Sset.Select acSelectionSetCrossing, llpnt, urpnt

'Calculate the midpnt of the selected points
Dim midpnt(0 To 2) As Double
midpnt(0) = (llpnt(0) + urpnt(0)) / 2
midpnt(1) = (llpnt(1) + urpnt(1)) / 2

'Select the point of where you want to place the selection
Dim destPnt As Variant
destPnt = ThisDrawing.Utility.GetPoint(, "Select Destination Point: ")
'Copy or Move all entities in selection set?
If MsgBox("Would you like to copy these entities?" & vbCrLf & "Press YES to COPY and" _
& " NO to MOVE", vbYesNo, "COPY/MOVE") = vbYes Then
 For Each ent In Sset
  ent.Copy
  ent.Move midpnt, destPnt
 Next ent
Else
 For Each ent In Sset
  ent.Move midpnt, destPnt
 Next ent
End If

ThisDrawing.Regen acActiveViewport

'Double check to make sure that you really want to make this change, otherwise, undo once
If MsgBox("Are you sure that you want to copy or move these entities?", vbYesNo, "COPY/MOVE") = vbYes Then
 Exit Sub
Else
 ThisDrawing.SendCommand "undo" & vbCr & "1" & vbCr
 ThisDrawing.Regen acActiveViewport
End If

End Sub

If you use the above code, you can get rid of the copy/move part and do a ZoomCenter to midpnt

That will still give you the original result that you were looking for

ML

For Tipo, it would be

ThisDrawing.Application.ZoomWindow llpnt, urpnt

Here is my old one, try this out

 

;;zw.lsp
;;zoom selection set by window

(vl-load-com)

(defun C:ZW  (/ a axss lp maxp minp points ss up)
 (setq    ss   (ssget)
   axss (vla-get-activeselectionset
          (vla-get-activedocument
        (vlax-get-acad-object))))
 (vlax-for a  axss
   (if    (not (vl-catch-all-error-p
          (vl-catch-all-apply
        (function (lambda ()
                (vla-getboundingbox a 'minp 'maxp))))))
     (setq points (append (list (vlax-safearray->list minp)
                (vlax-safearray->list maxp))
              points)
       )
     )
   )
 (setq    lp (car    (vl-sort points
            (function (lambda (a b)
                    (and (< (car a) (car b))
                     (< (cadr a) (cadr b)))))))
   up (car    (vl-sort points
            (function (lambda (a b)
                    (and (> (car a) (car b))
                     (> (cadr a) (cadr b)))))))
   )

 (vla-zoomwindow
   (vlax-get-acad-object)
     (vlax-3d-point lp)
      (vlax-3d-point up)
   )
 (princ)
 )

~'J'~

Hi fixo,

Please tell me, how to modify the above script if I want to

rotate selection set about the midpoint of these 2 points you use for zoom window ?

Hi fixo,

Please tell me, how to modify the above script if I want to

rotate selection set about the midpoint of these 2 points you use for zoom window ?

Try this one instead

;;rs.lsp
;;rotate selection set around its center
(vl-load-com)
; Convert value in radians to degrees
(defun rtd (a)
 (* 180.0 (/ a pi))
)
(defun C:RS  (/ a axss lp maxp minp midp points rot ss up)
 (setq    ss   (ssget)
   axss (vla-get-activeselectionset
          (vla-get-activedocument
        (vlax-get-acad-object))))
 (vlax-for a  axss
   (if    (not (vl-catch-all-error-p
          (vl-catch-all-apply
        (function (lambda ()
                (vla-getboundingbox a 'minp 'maxp))))))
     (setq points (append (list (vlax-safearray->list minp)
                (vlax-safearray->list maxp))
              points)
       )
     )
   )
 (setq    lp (car    (vl-sort points
            (function (lambda (a b)
                    (and (< (car a) (car b))
                     (< (cadr a) (cadr b)))))))
   up (car    (vl-sort points
            (function (lambda (a b)
                    (and (> (car a) (car b))
                     (> (cadr a) (cadr b)))))))
   )


 (vla-zoomwindow
   (vlax-get-acad-object)
     (vlax-3d-point lp)
      (vlax-3d-point up)
   )

 (setq midp (mapcar (function (lambda(a b)(/ (+ a b) 2.))) lp up))

 (initget 3)
 (setq rot (getreal "\nEnter a rotation angle in degrees: "))

 (vlax-for a  axss
 (vl-catch-all-apply
        (function (lambda ()
                (vla-rotate a (vlax-3d-point midp) (rtd rot)))))

     )

 (princ)
 )
(prompt "\n   >>>   Type RS to execute...")
(prin1)

~'J'~

Thank you for immediate response,

Unfortunately I can not test it because few hours earlier something strange happened to my ACA 2011-64bit.

When ACA is starting I see this in command line window:

.....
Loading Modeler DLLs.
AutoCAD menu utilities loaded.
AutoCAD Architecture menu utilities ; error: COM exception: %1 could not be found
....

& now I get this error with every script:

...no function definition: VLAX-GET-ACAD-OBJECT

Even zw.lsp is not working now, although it was OK earlier today.

(I didn't do anything except testing some old .lsp files from my PC.)

'Repair installation' didn't help - same errors again and again,

Any suggestions ?