[编程交流] VBA：行列表

Option Explicit
Sub AllLinesData()
   Dim oSset As AcadSelectionSet
   Dim oEnt As AcadEntity
   Dim fcode(0) As Integer
   Dim fData(0) As Variant
   Dim dxfcode, dxfdata
   Dim setName As String
   Dim i As Integer
   Dim n As Integer
   Dim s As String
   fcode(0) = 0
   fData(0) = "LINE"
   dxfcode = fcode
   dxfdata = fData
   setName = "$Lines$"
   '// make sure the selection set does not exist
   For i = 0 To ThisDrawing.SelectionSets.Count - 1
       If ThisDrawing.SelectionSets.Item(i).Name = setName Then
           '// if this named selection set is already exist then delete it
           ThisDrawing.SelectionSets.Item(i).Delete
           Exit For
       End If
   Next i
   '// add new selection set with this name
   Set oSset = ThisDrawing.SelectionSets.Add(setName)
   oSset.Select acSelectionSetAll, , , dxfcode, dxfdata
   On Error GoTo Err_Control
   '// loop through all lines
   ReDim lineArr(0 To oSset.Count - 1, 0 To 6) As Variant
   For n = 0 To oSset.Count - 1
       Dim cEnt As AcadEntity
       Set cEnt = oSset.Item(n)
       Dim oLine As AcadLine
       Set oLine = cEnt
       Dim startp As Variant
       '// get the start point
       startp = oLine.StartPoint
       Dim endp As Variant
       '// get the end point
       endp = oLine.EndPoint
       '// collect line handles and points into a two-dimensional array
       lineArr(n, 0) = oLine.Handle
       lineArr(n, 1) = startp(0)
       lineArr(n, 2) = startp(1)
       lineArr(n, 3) = startp(2)
       lineArr(n, 4) = endp(0)
       lineArr(n, 5) = endp(1)
       lineArr(n, 6) = endp(2)
   Next n
   '// clean up memory
   oSset.Delete
   '// do what you want with array 'lineArr' here, e.g. write data to the text file etc.
   Open "C:\AllLines.txt" For Output As #1    'Open file for output
   For n = 0 To UBound(lineArr, 1)
       s = ""
       For i = 0 To UBound(lineArr, 2)
           s = s & CStr(lineArr(n, i)) & ","
       Next i
       Write #1, Left(s, Len(s) - 1)    'Write comma-delimited data (cut the last comma from string)
   Next n
   Close #1    'Close file
Err_Control:
   MsgBox Err.Description
End Sub