Jump to content

Bounding Box for Selection Set


abraxus

Recommended Posts

What would be the best way to get a bounding box for a selection set in VBA?

 

Google found a LISP routine that can do it, but it has been years since I have used LISP

 

I was thinking someone here might be easily able to convert this small LISP routine to VBA for me

 

(defun LM:SSBoundingBox ( ss / i l1 l2 ll ur )
 (repeat (setq i (sslength ss))
   (vla-getboundingbox (vlax-ename->vla-object (ssname ss (setq i (1- i)))) 'll 'ur)
   (setq 
     l1 (cons (vlax-safearray->list ll) l1) 
     l2 (cons (vlax-safearray->list ur) l2)
   )
  )
  (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list l1 l2))
)

Link to comment
Share on other sites

i guess now that i think about it - it's probably not all that hard to just iterate thru each item in the selection set and track the min and max x and y coords... i guess i was just thinking that autocad would have this built in... guess not

Link to comment
Share on other sites

ok, so yeah, i feel like an idiot for even asking this question now

 

here's the solution for those of you who wondered

 

Public Sub GetSSBoundingBox(ss As AcadSelectionSet, ptMin As Variant, ptMax As Variant)
 Dim entItem As AcadEntity
 Dim ptImin As Variant
 Dim ptImax As Variant
 Const X = 0
 Const Y = 1

 ss(0).GetBoundingBox ptMin, ptMax
 For Each entItem In ss
   entItem.GetBoundingBox ptImin, ptImax
   If ptImin(X) < ptMin(X) Then ptMin(X) = ptImin(X)
   If ptImin(Y) < ptMin(Y) Then ptMin(Y) = ptImin(Y)
   If ptImax(X) > ptMax(X) Then ptMax(X) = ptImax(X)
   If ptImax(Y) > ptMax(Y) Then ptMax(Y) = ptImax(Y)
 Next

End Sub

 

and here is how to call the function

 

Public Sub FlipTest()
 Dim ssFlip As AcadSelectionSet
 Dim pt1 As Variant
 Dim pt2 As Variant

 ' get selection set from user
 Set ssFlip = ThisDrawing.SelectionSets.Add("flip")
 ssFlip.SelectOnScreen
 
 ' get bounding box of selection set
 GetSSBoundingBox ssFlip, pt1, pt2
 
 ' draw a line from point to point
 ThisDrawing.ModelSpace.AddLine pt1, pt2
 
 ssFlip.Delete
 
End Sub

Link to comment
Share on other sites

  • 3 years later...

selvamani the code does this look at ptimin ptimax . You can pass these to a plot window sub and say use Fit. There is lots of plot code here mainly lisp but I am sure you can find a VBA version, if thats what you want. https://forums.autodesk.com/t5/autocad-forum/plotting-in-a-vba-script/td-p/3249378

 

abraxus a check for which space your in may be a good idea. Tested in a layout and drew a line in model space. Nice code though can see lots of use like plotting.

Edited by BIGAL
Link to comment
Share on other sites

thanks BIGAL

 

i need to find specific block which is used multiple times in a cad and and change its attributes values one by one through vba

 

any help on this please

Link to comment
Share on other sites

this points iam getting from bounding box in main sub

i dont know what is happenning i got only empty window as layout but actually points given to setplotwindow is not empty plese help on this code for your reference

 

 

 

Sub Example_SetWindowToPlot(point1 As Variant, point2 As Variant)

' This example allows the user to define an area in the current layout

' and displays a plot preview of the defined area.

'

' * Note: You have to exit the

' plot preview before the VBA example will stop and control will be returned

 

AppActivate ThisDrawing.Application.Caption

 

' Dim point1 As Variant, point2 As Variant

 

' Get first point in window

'point1 = ThisDrawing.Utility.GetPoint(, "Click the lower-left of the window to plot.")

ReDim Preserve point1(0 To 1) ' Change this to a 2D array by removing the Z position

 

' Get second point in window

'point2 = ThisDrawing.Utility.GetPoint(, "Click the upper-right of the window to plot.")

ReDim Preserve point2(0 To 1) ' Change this to a 2D array by removing the Z position

 

' Send information about window to current layout

ThisDrawing.ActiveLayout.SetWindowToPlot point1, point2

ThisDrawing.Plot.DisplayPlotPreview acFullPreview

 

' Read back window information

ThisDrawing.ActiveLayout.GetWindowToPlot point1, point2

 

MsgBox "Press any key to plot the following window:" & vbCrLf & vbCrLf & _

"Lower Left: " & point1(0) & ", " & point1(1) & vbCrLf & _

"Upper Right: " & point2(0) & ", " & point2(1)

 

' Be sure to plot a view, not some other plot style

ThisDrawing.ActiveLayout.PlotType = acWindow

 

' Send Plot To Window

ThisDrawing.ActiveLayout.ConfigName = "DWG to PDF.pc3"

ThisDrawing.Plot.DisplayPlotPreview acFullPreview

End Sub

Link to comment
Share on other sites

  • 2 years later...

How do you get the dimensions length and width of the bounding box. Also if the shape is rotated how could i make that work  something like  LM:minboundingbox.

I'm working on a macro to get a shape max and min dimensions to export to exel file. thinking it would be easier in vba then Lisp  

Link to comment
Share on other sites

The length and width can be calculated by subtracting the minimum X/Y values from the maximum X/Y values. If it is rotated then you would need to rotate the objects back to a 0 rotation before getting the bounding box. You can do this with temporary objects you create by making a copy of them first, and then deleting them after the calculations have been made. The way a bounding box works is that it has to be based on 90 degree values from the WCS.

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...