Jump to content

Get bounding box from EXCEL


katto01

Recommended Posts

Hello,

 

I am trying to get the bounding box for all entities on a layer.

I would like to be able to do this from EXCEL. I tried to modify an AutoCAD VBA routine that works in the AutoCAD VBA to work in EXCEL, however I seem to miss something. Please see my code below. It fails at the ss(0).. line.

Please advise

Thank you

Sub Get_BoundingBox()

Dim XNAME As String
'On Error Resume Next 'This tells VBA to ignore errors
Set ACAD = GetObject(, "AutoCAD.Application") 'Get a running instance of the class AutoCAD.Application

Dim ssetObj As AcadSelectionSet
Dim sset As AcadSelectionSets
Dim acadobj As AcadObject
Dim objname As String
Dim ptllmin As Variant
Dim ptllmax As Variant
Dim HH As Variant
Dim objlayer As String
Dim entItem As AcadEntity

Dim I As Integer
Dim corner1(0 To 2) As Double
Dim corner2(0 To 2) As Double

corner1(0) = -10000000000#: corner1(1) = -10000000000#: corner1(2) = 0
corner2(0) = 10000000000#: corner2(1) = 10000000000#: corner2(2) = 0

I = 0

Set sset = ACAD.ActiveDocument.SelectionSets

For Each ssetObj In sset
If UCase(ssetObj.Name) = "TEST" Then
sset.Item("TEST").Delete
Exit For
End If
Next

Set ssetObj = ACAD.ActiveDocument.SelectionSets.Add("TEST")

' Add all the objects to the selection set
ssetObj.Select acSelectionSetAll
Q$ = Chr(9)
For Each acadobj In ssetObj
objname = acadobj.ObjectName
objlayer = acadobj.Layer
HH = acadobj.Handle
 
 Const X = 0
 Const Y = 1

 ss(0).GetBoundingBox ptMin, ptMax
 For Each entItem In ss
    ACAD.ActiveDocument.entItem.GetBoundingBox ptllmin, ptllmax
   If ptllmin(X) < ptMin(X) Then ptMin(X) = ptllmin(X)
   If ptllmin(Y) < ptMin(Y) Then ptMin(Y) = ptllmin(Y)
   If ptllmax(X) > ptMax(X) Then ptMax(X) = ptllmax(X)
   If ptllmax(Y) > ptMax(Y) Then ptMax(Y) = ptllmax(Y)
 Next
Sheet5.Cells(I, 1).Value = I
Debug.Print objname, Q$, objlayer, Q$, HH
I = I + 1
Sheet5.Cells(I, 1).Value = I
Sheet5.Cells(I, 2).Value = objname
Sheet5.Cells(I, 3).Value = objlayer
Sheet5.Cells(I, 4).Value = HH
Sheet5.Cells(I, 5).Value = ptMin(X)
Sheet5.Cells(I, 6).Value = ptMin(Y)
Sheet5.Cells(I, 7).Value = ptMax(X)
Sheet5.Cells(I, 7).Value = ptMax(Y)

Next acadobj

End Sub


Link to comment
Share on other sites

I am no expert on VBA but compare this code by lee-mac and you can see that you are missing an object when calling the bounding box.

 

(vl-catch-all-apply 'vla-getboundingbox (list obj 'a 'b))

 

Also ss(0) maybe just ss and why bounding box call twice ?

 

Look into variables extmax extmin also

 

lisp version

(setq ss (ssget))
(repeat (setq x (sslength ss))
(setq obj (vlax-ename->vla-object (ssname ss (setq x (- x 1))))
(vla-getboundingbox obj 'll 'ur)
(setq ll(vlax-safearray->list ll))
(setq ur (vlax-safearray->list ur))
(princ ll)
)

Edited by BIGAL
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...