[编程交流] LIST命令的VBA代码

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