Sub ListProps()
Dim ssPolys As AcadSelectionSet
Dim ssName As String
Dim intCodes()As Integer
Dim varValues As Variant
Dim objEnt As AcadEntity
Dim objLWPoly As AcadLWPolyline
Dim objPoly As AcadPolyline
Dim strName As String
Dim strLayer As String
Dim strHandle As String
Dim strClosed As String
Dim dblWidth As Double
Dim dblArea As Double
Dim dblPerim As Double
Dim dblCoords() As Double
On Error Resume Next
ssName = "ssPolys"
' try to set the selection set
Set ssPolys = ThisDrawing.SelectionSets(ssName)
' if it does not exist an error will occur - so add it
If Err Then
Set ssPolys = ThisDrawing.SelectionSets.Add(ssName)
End If
' clear all data from selection set
ssPolys.Clear
' set the filter
ReDim intCodes(5): ReDim varValues(5)
intCodes(0) = -4: varValues(0) = "<and"
intCodes(1) = -4: varValues(1) = "<or"
intCodes(2) = 0:varValues(2) = "PolyLine"
intCodes(3) = 0:varValues(3) = "LwPolyLine"
intCodes(4) = -4: varValues(4) = "or>"
intCodes(5) = -4: varValues(5) = "and>"
ssPolys.Select acSelectionSetAll, , , intCodes, varValues
' now make your connection to Excel
' now you have all the polylines in a selection set iterate it to get the properties
For Each objEnt In ssPolys
strClosed = "Open"
If objEnt.ObjectName = "AcDbPolyline" Then
strName = "Polyline2D" 'objLWPoly.ObjectName
Else
strName = "LWPolyline" 'objPoly.ObjectName
End If
' extract the properties
strName = objEnt.ObjectName
strLayer = objEnt.Layer
strHandle = objEnt.Handle
If objEnt.Closed = True Then strClosed = "Closed"
dblWidth = objEnt.ConstantWidth
dblArea = objEnt.Area
dblPerim = objEnt.Length
dblCoords = objEnt.Coordinates
' send the above properties to Excel
' iterate through the coords array and send the coordinates to Excel
Next objEnt
' close your connection to Excel
End Sub
太好了，这就是我想要的。
你忽略了吗？
页:
1
[2]