VBA：行列表
在VBA中是否可以创建图形中所有直线（及其起点和终点坐标）的列表？VBA（或VB）对我来说并不新鲜，但与Autocad的结合却是。 对
为线实体创建过滤的选择集，然后迭代该选择集，查询所需的属性。帮助文件包含过滤选择集的示例，这里有一个很好的教程：http://usa.autodesk.com/adsk/servlet/item?siteID=123112&id=2768231&linkID=9240615
欢迎加入！
试试这个例子
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
~'J'~ 谢谢，尝试了代码，它满足了我的需要。有了这段代码，我可以完成我的程序多一点。 不客气
很乐意帮忙
~'J'~ 我添加了代码以获得LWpolyline的开始点和结束点。这适用于具有1个顶点的LWD多段线。当我绘制具有多个顶点的LW多段线时，我看到组码“90”表示顶点的数量。我如何读取组码“90”的上下文，或者是否有其他方法来确定顶点的数量？ 试着读读这个稍微编辑过的版本
选项显式sub AllPlinesData（）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）=“LWPOLYLINE”dxfcode=fcode dxfdata=fData setName=“$Plines$”//确保此图形的i=0的选择集不存在。选择集。如果此绘图，则计数-1。选择集。项目（i）。Name=setName Then'//如果此命名选择集已存在，请将其删除ThisDrawing。选择集。项目（i）。Delete Exit For End If Next i’//添加具有此名称集的新选择集oSset=ThisDrawing。选择集。添加（setName）oSset。选择acSelectionSetAll、dxfcode、dxfdata On Error GoTo Err\u Control’//循环通过所有轻多段线ReDim plineAr（0到oSset。计数-1，0到4），作为n=0到oSset的变量。Count-1 Dim cEnt作为AcadEntity Set cEnt=oSset。Item（n）Dim oPline As AcadLWPolyline Set oPline=cEnt Dim coord As Variant’//get coordinates coord=oPline。坐标'//将多段线控制柄和点收集到二维数组plineAr（n，0）=oPline中。手柄多线性（n，1）=坐标（0）' 代码仅返回多段线的开始和结束。我将部分代码更改为：
'//获取坐标坐标=oPline。坐标“//将多段线句柄和点收集到二维arrayxtemp=coord（0）”中 puffeltje，
我尝试将您的代码合并到Fixo提供的示例代码中，但无法执行。你能帮忙吗。想试试你的代码。
谢谢 Oeps，我没有发布我所有的更改：哎呀：。以下是工作代码：
选项显式sub AllPlinesData（）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 Dim xtemp Dim ytemp Dim j Dim PLindex fcode（0）=0 fData（0）=“LWPOLYLINE”dxfcode=fcode dxfdata=fData setName=“$Plines$”//确保此图形的i=0的选择集不存在。选择集。如果此绘图，则计数-1。选择集。项目（i）。Name=setName Then'//如果此命名选择集已存在，请将其删除ThisDrawing。选择集。项目（i）。Delete Exit For End If Next i’//添加具有此名称集的新选择集oSset=ThisDrawing。选择集。添加（setName）oSset。选择acSelectionSetAll、、dxfcode、dxfdata On Error GoTo Err\u Control’//循环通过所有轻多段线ReDim plinear（0到3，0到oSset。Count-1）作为变量PLindex=0，对于n=0到oSset。Count-1 Dim cEnt作为AcadEntity Set cEnt=oSset。Item（n）Dim oPline As AcadLWPolyline Set oPline=cEnt Dim coord As Variant’//get coordinates coord=oPline。坐标“//将多段线句柄和点收集到二维数组xtemp=coord（0）”中
页:
[1]
2