Polyline / Polygon Area

[Bittuds1996]

Dear Experts,

I have tried the attached Code But when I run "Run-time error "-2145320851" show

I Need your help on this subject

Sub ExtractPolygonAreas()

Dim acadApp As Object
Dim acadDoc As Object
Dim acadSelSet As Object
Dim acadPoly As Object

Set acadApp = GetObject(, "AutoCAD.Application")
Set acadDoc = acadApp.ActiveDocument

Set acadSelSet = acadDoc.SelectionSets.Add("polygons")
acadSelSet.SelectOnScreen

Dim i As Integer
Dim j As Integer
Dim area As Double
Dim pointArray() As Double

Dim xlApp As Object
Dim xlWb As Object
Dim xlWs As Object

Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Add
Set xlWs = xlWb.Sheets("Sheet1")

xlWs.Cells(1, 1).Value = "Layer"
xlWs.Cells(1, 2).Value = "Coordinates"
xlWs.Cells(1, 3).Value = "Area"

For i = 0 To acadSelSet.Count - 1
Set acadPoly = acadSelSet.Item(i)
area = acadPoly.area
pointArray = acadPoly.Coordinates
xlWs.Cells(i + 2, 1).Value = acadPoly.Layer
xlWs.Cells(i + 2, 2).Value = "("
For j = 0 To UBound(pointArray) - 1 Step 2
xlWs.Cells(i + 2, 2).Value = xlWs.Cells(i + 2, 2).Value & "(" & pointArray(j) & "," & pointArray(j + 1) & ")"
Next j
xlWs.Cells(i + 2, 2).Value = xlWs.Cells(i + 2, 2).Value & ")"
xlWs.Cells(i + 2, 3).Value = area
Next i

xlApp.Visible = True
xlWb.SaveAs "PolygonAreas.xlsx"

End Sub

 

[PeterPan9720]

Hi

did you try to run procedure step by step with F8 function key ? just to understand with debugging the hang point.

As second issue where are you devoloping the above procedure inside Autocad VBA or Excel VBA ?

[BIGAL]

Peterpan yes run from excel.

 

Worked for me, are you trying to run in say Bricscad need a different "get application". Also need the co-ords to go down a row for each co-ordinate at moment all in 1 cell.

 

Can do this from Acad, Bricscad etc open a new excel and fill in excel values. Its the same method but done in VL code.

 

[BIGAL]

Bricscad (vlax-get-or-create-object "BricsCadApp.AcadApplication")