Discussion forum

Message Topic Search Topic Options Post Reply Create New Topic Printable Version Translate Topic

   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

CZ \| EN \| DE
Login or
registration
	Visitors: 4153

Author	Message Topic Search Topic Options Post Reply Create New Topic Printable Version Translate Topic
katto01 Members Profile Find Members Posts Newbie Joined: 24.Jun.2009 Location: Japan Using: ZWCAD Status: Offline Points: 17	Topic: VBA GetBox Posted: 16.Jul.2018 at 17:38
	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

	CAD Forum - tips, tricks, utilities, discussion for AutoCAD, LT, Inventor, Revit, Map, Civil 3D, 3ds Max, Fusion 360 and other Autodesk software (support by Arkance Systems)	Arkance Systems CZ (CAD Studio) - Autodesk Platinum Partner & Training Center & Services Partner	CONTACT: webmaster.cz@arkance-systems.com tel. +420 910 970 111
	Copyright ©2024 \| Advertise with us \| Online privacy

Discussion forum

CAD discussion

VBA GetBox