获取二维多线段子实体的方法

zhoumh989

在测绘软件cass(基于cad开发），有界址线，一个闭合的多线段，整个线有个整地的扩展属性，在组吗1000中，“south”来存储信息
但是每两个顶点之间的线段，单独也有一个属性，属于前面多线段的子实体（VERTEX)，这个子实体怎么获取呢，
在cad 用list命令行可以看到二维多线段的子实体。但是vba读取不到，lwpolyline没有这个属性或者方法，
  
  之前在网上找了一个间接的方法，通过创建类，来获取子实体的句柄，然后根据句柄到实体来得到这个实体，但是比较麻烦，还需要该CAD2006.FAS文件，创建类，不知道有没有更便捷的方法。直接得到这个子实体。

marting

既然你说了是二维多段线，那就是POLYLINE而不是LWPOLYLINE了，用 (entnext pl )  pl是主实体，就能得到子实体VERTEX

zhoumh989

marting 发表于 2017-6-27 00:09

好的，谢谢，明天试试，请问用vba怎么实现呢，这是lisp语言，

marting

zhoumh989 发表于 2017-6-27 00:15

不知道你用什么版本的CAD，不推荐你在用VBA了， 方便的有LISP，高级些的有.NET，再高级的有ARX。

下面是VBA的代码，获取OLD POLYLINE 的顶点的XDATA

1. Sub GetXDataFromVertexOfPLine()
   
2.    Dim objEnt As AcadEntity
   
3.    Dim objCopy As AcadEntity
   
4.    Dim objPl As AcadPolyline
   
5.    Dim varPick As Variant
   
6.    Dim xdataOut As Variant
   
7.    Dim xtypeOut As Variant
   
8.    Dim strAppNames As String
   
9.    Dim i, j As Integer
   
10.    Dim num As Integer
    
11.    Dim strHandle As String
    
12.    Dim lonHandle As Long
    
13. 
    
14.    On Error Resume Next
    
15. 
    
16.    ThisDrawing.Utility.GetEntity objEnt, varPick, "Select an old Polyline: "
    
17.    If objEnt Is Nothing Then
    
18.     MsgBox "Nothing selected."
    
19.     Exit Sub
    
20.    Else
    
21.     If objEnt.ObjectName = "AcDb2dPolyline" Then    'an old 2d polyline
    
22.         Set objCopy = objEnt.Copy
    
23.         objEnt.Delete
    
24.         Set objEnt = Nothing
    
25.         Set objEnt = objCopy
    
26.         Set objCopy = Nothing
    
27. 
    
28.         objEnt.GetXData "", xtypeOut, xdataOut
    
29.         If VarType(xtypeOut) = vbEmpty Then
    
30.         MsgBox "No XDATA for polyline header."
    
31.         Else
    
32.         strAppNames = ""
    
33.         For i = LBound(xtypeOut) To UBound(xtypeOut) Step 1
    
34.             If xtypeOut(i) = 1001 Then
    
35.             strAppNames = strAppNames & xdataOut(i) & vbCrLf
    
36.             End If
    
37.         Next
    
38.         If strAppNames <> "" Then
    
39.             MsgBox "XDATA App names:" & vbCrLf & vbCrLf & strAppNames
    
40.         End If
    
41.         End If
    
42.     Else
    
43.         MsgBox "Non old polyline selected!"
    
44.         Exit Sub
    
45.     End If
    
46. 
    
47.     Set objPl = objEnt
    
48.     objEnt = Nothing
    
49. 
    
50.     num = (UBound(objPl.Coordinates) - LBound(objPl.Coordinates) + 1) / 3
    
51.     strHandle = objPl.Handle
    
52.     Set objPl = Nothing
    
53.     lonHandle = Val("&H" & strHandle) + 1
    
54.     strHandle = Hex(lonHandle)
    
55.     Set objEnt = ThisDrawing.Database.HandleToObject(strHandle)
    
56. 
    
57.     For j = 1 To num Step 1
    
58.         objEnt.GetXData "", xtypeOut, xdataOut
    
59.         If VarType(xtypeOut) = vbEmpty Then
    
60.         MsgBox "No XDATA for No. " & j & " vertex."
    
61.         Else
    
62.         strAppNames = ""
    
63.         For i = LBound(xtypeOut) To UBound(xtypeOut) Step 1
    
64.             If xtypeOut(i) = 1001 Then
    
65.             strAppNames = strAppNames & xdataOut(i) & vbCrLf
    
66.             End If
    
67.         Next
    
68.         If strAppNames <> "" Then
    
69.             MsgBox "XDATA App names of vertex " & j & " :" & vbCrLf &
    
70. vbCrLf & strAppNames
    
71.         End If
    
72.         End If
    
73. 
    
74.         strHandle = objEnt.Handle
    
75.         lonHandle = Val("&H" & strHandle) + 1
    
76.         strHandle = Hex(lonHandle)
    
77.         Set objEnt = ThisDrawing.Database.HandleToObject(strHandle)
    
78.     Next
    
79. 
    
80.    End If
    
81. 
    
82. End Sub
    

Sub GetXDataFromVertexOfPLine()<br />    Dim objEnt As AcadEntity<br />    Dim objCopy As AcadEntity<br />    Dim objPl As AcadPolyline<br />    Dim varPick As Variant<br />    Dim xdataOut As Variant<br />    Dim xtypeOut As Variant<br />    Dim strAppNames As String<br />    Dim i, j As Integer<br />    Dim num As Integer<br />    Dim strHandle As String<br />    Dim lonHandle As Long<br /> <br />    On Error Resume Next<br /> <br />    ThisDrawing.Utility.GetEntity objEnt, varPick, "Select an old Polyline: "<br />    If objEnt Is Nothing Then<br />     MsgBox "Nothing selected."<br />     Exit Sub<br />    Else<br />     If objEnt.ObjectName = "AcDb2dPolyline" Then    'an old 2d polyline<br />         Set objCopy = objEnt.Copy<br />         objEnt.Delete<br />         Set objEnt = Nothing<br />         Set objEnt = objCopy<br />         Set objCopy = Nothing<br /> <br />         objEnt.GetXData "", xtypeOut, xdataOut<br />         If VarType(xtypeOut) = vbEmpty Then<br />         MsgBox "No XDATA for polyline header."<br />         Else<br />         strAppNames = ""<br />         For i = LBound(xtypeOut) To UBound(xtypeOut) Step 1<br />             If xtypeOut(i) = 1001 Then<br />             strAppNames = strAppNames & xdataOut(i) & vbCrLf<br />             End If<br />         Next<br />         If strAppNames <> "" Then<br />             MsgBox "XDATA App names:" & vbCrLf & vbCrLf & strAppNames<br />         End If<br />         End If<br />     Else<br />         MsgBox "Non old polyline selected!"<br />         Exit Sub<br />     End If<br /> <br />     Set objPl = objEnt<br />     objEnt = Nothing<br /> <br />     num = (UBound(objPl.Coordinates) - LBound(objPl.Coordinates) + 1) / 3<br />     strHandle = objPl.Handle<br />     Set objPl = Nothing<br />     lonHandle = Val("&H" & strHandle) + 1<br />     strHandle = Hex(lonHandle)<br />     Set objEnt = ThisDrawing.Database.HandleToObject(strHandle)<br /> <br />     For j = 1 To num Step 1<br />         objEnt.GetXData "", xtypeOut, xdataOut<br />         If VarType(xtypeOut) = vbEmpty Then<br />         MsgBox "No XDATA for No. " & j & " vertex."<br />         Else<br />         strAppNames = ""<br />         For i = LBound(xtypeOut) To UBound(xtypeOut) Step 1<br />             If xtypeOut(i) = 1001 Then<br />             strAppNames = strAppNames & xdataOut(i) & vbCrLf<br />             End If<br />         Next<br />         If strAppNames <> "" Then<br />             MsgBox "XDATA App names of vertex " & j & " :" & vbCrLf &<br /> vbCrLf & strAppNames<br />         End If<br />         End If<br /> <br />         strHandle = objEnt.Handle<br />         lonHandle = Val("&H" & strHandle) + 1<br />         strHandle = Hex(lonHandle)<br />         Set objEnt = ThisDrawing.Database.HandleToObject(strHandle)<br />     Next<br /> <br />    End If<br /> <br /> End Sub<br />

zhoumh989

marting 发表于 2017-6-27 00:24

放进去好像不行，
网上找了一个方法 http://blog.sina.com.cn/s/blog_48ff6e1401009b56.html
但是执行的时候就获取不到，
他是根据lisp函数引入到vba的