Hello everyone
I found this code and edited it. It can be listed all polylines with their areas and length on the excel, i want to also calculate to length of line on the these polylines. What should i need to do ?
As example,
Capture.PNG
LWPoly nr Layer Area Length Door length
1 Wall01 20 18 1.5
2 Wall02 30 22 2
Code:
--------------------------------------------------------------
Option Explicit
Sub PickLwPolysAndGetData()
'for Excel sheet managing purposes
Dim MySht As Worksheet
Dim MyCell As Range
'for Autocad application managing purposes
Dim ACAD As AcadApplication
Dim ThisDrawing As AcadDocument
Dim LWPoly As AcadLWPolyline
Dim mtext As AcadMText
' for selection set purposes
Dim ssetObj As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
'for general variables managing purposes
Dim iRow As Long
Dim LWArea As Double, LWPerimeter As Double, LWLayer As Variant, amtext As Variant
' Autocad Session handling
On Error Resume Next
Set ACAD = GetObject(, "AutoCAD.Application")
On Error GoTo 0
If ACAD Is Nothing Then
Set ACAD = New AcadApplication
ACAD.Visible = True
End If
Set ThisDrawing = ACAD.ActiveDocument
' selecting LwPolylines on screen by selelection set filtering method
' managing potential selection set exsistence
On Error Resume Next
Set ssetObj = ThisDrawing.SelectionSets.Item("LWPolySSET")
If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("LWPolySSET")
On Error GoTo 0
ssetObj.Clear
'setting filtering critera
gpCode(0) = 0
dataValue(0) = "LWPOLYLINE"
'selecting LWPolylines
ssetObj.SelectOnScreen gpCode, dataValue
' processing LWPolylines
If ssetObj.Count > 0 Then
' writing sheet headings
Set MySht = ActiveSheet
Set MyCell = MySht.Cells(1, 1)
With MyCell
.Offset(0, 0).Value = "LWPoly nr"
.Offset(0, 1).Value = "Layer"
.Offset(0, 2).Value = "Area"
.Offset(0, 3) = "Length"
End With
'clearing previous written data
iRow = MySht.Cells(MySht.Rows.Count, 1).End(xlUp).Row
If iRow > 1 Then MyCell.Offset(1, 0).Resize(iRow - 1, 3).Clear
'retrieving LWPolys data and writing them on worksheet
iRow = 1
For Each LWPoly In ssetObj
'retrieving LWPoly data
With LWPoly
LWArea = .Area
LWPerimeter = .Length
LWLayer = .Layer
End With
' writing LWPoly data
With MyCell
.Offset(iRow, 0).Value = "LWPoly nr." & iRow
.Offset(iRow, 1).Value = LWLayer
.Offset(iRow, 2).Value = LWArea
.Offset(iRow, 3).Value = LWPerimeter
End With
iRow = iRow + 1
Next LWPoly
End If
' cleaning up before ending
ssetObj.Delete
Set ssetObj = Nothing
Set ThisDrawing = Nothing
Set ACAD = Nothing
End Sub
------------------------------------------------------------