[求助]怎样用VBA读取CASS软件内每个界址线段的扩展属性

lihengmin

怎样用VBA读取CASS软件内每个界址线段的扩展属性

雪山飞狐_lzh

发图上来看看

lihengmin

此界址线整个有扩展属性，但每条线段上也有扩展属性，请您看看

雪山飞狐_lzh

命令: xdlist
选择对象:
Enter application name <*>:

* Registered Application Name: qhdm
* Code 1000, ASCII string: 13

* Registered Application Name: YZDH
* Code 1000, ASCII string:

* Registered Application Name: YDJMJ
* Code 1040, Real number: 0.0000

* Registered Application Name: GLZDBH
* Code 1000, ASCII string:

* Registered Application Name: GLFS
* Code 1000, ASCII string:

* Registered Application Name: PCMJ
* Code 1040, Real number: 0.0000

* Registered Application Name: KZMJ
* Code 1040, Real number: 0.0000

* Registered Application Name: ZDMJ
* Code 1040, Real number: 7738.2240

* Registered Application Name: TDZL
* Code 1000, ASCII string: 济南市经济开发区高垣墙村

* Registered Application Name: SZTFH
* Code 1000, ASCII string: 4049.00-478.25

* Registered Application Name: YYTFH
* Code 1000, ASCII string:

* Registered Application Name: DJKBH
* Code 1000, ASCII string:

* Registered Application Name: QLRDM
* Code 1000, ASCII string: 中国网通有限责任公司济南分公司

* Registered Application Name: QLRZS
* Code 1070, 16-bit integer: 1

* Registered Application Name: QSXZ
* Code 1000, ASCII string: 100 国有土地

* Registered Application Name: TDSYZ
* Code 1000, ASCII string: 中国网通有限责任公司济南分公司

* Registered Application Name: SYQLX
* Code 1000, ASCII string: 2 出让

* Registered Application Name: WFLX
* Code 1000, ASCII string:

* Registered Application Name: GYSYQQK
* Code 1000, ASCII string:

* Registered Application Name: ZZRQ
* Code 1000, ASCII string:
-More-

* Registered Application Name: TDDJ
* Code 1000, ASCII string: 01 一级

* Registered Application Name: SBDJ
* Code 1040, Real number: 0.0000

* Registered Application Name: BDDJ
* Code 1040, Real number: 0.0000

* Registered Application Name: SYQX
* Code 1000, ASCII string:

* Registered Application Name: JZRJL
* Code 1040, Real number: 0.5500

* Registered Application Name: JZMD
* Code 1040, Real number: 0.2304

* Registered Application Name: JZWZDMJ
* Code 1040, Real number: 1783.2050

* Registered Application Name: SBJZWQS
* Code 1000, ASCII string:

* Registered Application Name: QSZMWJLX
* Code 1000, ASCII string:

* Registered Application Name: QSZMWJBH
* Code 1000, ASCII string:

* Registered Application Name: QSZMWJRQ
* Code 1000, ASCII string:

* Registered Application Name: QSLYZM
* Code 1000, ASCII string:

* Registered Application Name: ZDDZ
* Code 1000, ASCII string: 高垣墙村土地

* Registered Application Name: ZDNZ
* Code 1000, ASCII string: 高垣墙村土地

* Registered Application Name: ZDXZ
* Code 1000, ASCII string: 经十西路

* Registered Application Name: ZDBZ
* Code 1000, ASCII string: 巷道

* Registered Application Name: ZDT
* Code 1000, ASCII string:

* Registered Application Name: JXXZ
* Code 1000, ASCII string:

* Registered Application Name: YWZY
* Code 1000, ASCII string:

* Registered Application Name: DCBH
* Code 1000, ASCII string:
-More-

* Registered Application Name: ZJWTS
* Code 1000, ASCII string:

* Registered Application Name: YBDH
* Code 1000, ASCII string:

* Registered Application Name: SM
* Code 1000, ASCII string:

* Registered Application Name: ZJRQZ
* Code 1000, ASCII string:

* Registered Application Name: QSDCJS
* Code 1000, ASCII string:

* Registered Application Name: DCY
* Code 1000, ASCII string:

* Registered Application Name: DCRQ
* Code 1000, ASCII string:

* Registered Application Name: ZDCT
* Code 1000, ASCII string:

* Registered Application Name: DJKZJS
* Code 1000, ASCII string:

* Registered Application Name: KZY
* Code 1000, ASCII string:

* Registered Application Name: KZRQ
* Code 1000, ASCII string:

* Registered Application Name: DCSHYJ
* Code 1000, ASCII string:

* Registered Application Name: DCSHR
* Code 1000, ASCII string:

* Registered Application Name: DCSHRQ
* Code 1000, ASCII string:

* Registered Application Name: TDZH
* Code 1000, ASCII string:

* Registered Application Name: ZJBH
* Code 1000, ASCII string: 3701130010010018

* Registered Application Name: RKSJ
* Code 1000, ASCII string: 20070412

* Registered Application Name: RKRYDM
* Code 1000, ASCII string: L-06

* Registered Application Name: XGSJ
* Code 1000, ASCII string:

* Registered Application Name: XGRYDM
* Code 1000, ASCII string:
-More-

* Registered Application Name: SOUTH
* Code 1000, ASCII string: 300000
* Code 1000, ASCII string: 0010010018000
* Code 1000, ASCII string: 中国网通有限责任公司济南分公司
* Code 1000, ASCII string: 085

* Registered Application Name: TDYT
* Code 1000, ASCII string: 085 文体娱乐用地

Object has 15612 bytes of Xdata space available.

lihengmin

谢谢您，这些俺也能读，还有，每个线段上也有相应的扩展属性，1点～2点的属性如下，我是想用程序怎样连续读出

1001,YZDJH
1000,
1001,JZBC
1040,0
1001,JZXLB
1000,2 墙壁
1001,JZXWZ
1000,3 外
1001,JZXLX
1000,1 地面界址线
1001,JXXZ
1000,30 未定界
1001,ZZDZJR
1000,
1001,BZDZJRQ
1000,
1001,YZDZJR
1000,
1001,LZDZJRQ
1000,
1001,ZZZJWTS
1000,
1001,YZZJWTS
1000,
1001,WYTZS
1000,
1001,JZXFHDM
1000,
1001,RKSJ
1000,
1001,RKRYDM
1000,
1001,XGSJ
1000,
1001,XGRYDM
1000,

雪山飞狐_lzh

CASS把Ｘｄａｔａ放在Vertex对象了，而ＶＢＡ的对象模型没有提供该对象
可以将多段线的handle依次循环加一，再调用HandleToObject获得该对象
如你的例图的Handle为464
用Set oVertex1 = ThisDrawing.HandleToObject("466")获得第二个Vertex对象，再调用GetXData
测试代码

2. Sub tt()
3.     Dim oVertex1 As AcadObject
4.     Dim i
5.     Dim xt, xd
6.     Dim s As String
7.    
8.     Set oVertex1 = ThisDrawing.HandleToObject("466")
9.    
10.     oVertex1.GetXData "", xt, xd
11.     For i = 0 To UBound(xd)
12.         s = s & vbCrLf & xd(i)
13.     Next i
14.    
15.     MsgBox s
16. End Sub

Sub tt()     Dim oVertex1 As AcadObject     Dim i     Dim xt, xd     Dim s As String         Set oVertex1 = ThisDrawing.HandleToObject("466")         oVertex1.GetXData "", xt, xd     For i = 0 To UBound(xd)         s = s & vbCrLf & xd(i)     Next i         MsgBox s End Sub

lihengmin

谢谢您，但界址线如进行了加点后，它的句柄就变了，如上图，有上面好的办法没有？

雪山飞狐_lzh

那就用Vlax类吧

雪山飞狐_lzh

VBA代码

2. Function GetVertexs(Ent As AcadEntity) As Variant
3.     Dim n As Integer
4.     Dim oVertexs() As AcadObject
5.     Dim sName As String
6.     sName = UCase(Ent.ObjectName)
7.    
8.     If sName = "ACDB2DPOLYLINE" Or sName = "ACDB3DPOLYLINE" Then
9.         n = (UBound(Ent.Coordinates) + 1) / 3
10.     End If
11.    
12.     If n = 0 Then Exit Function
13.    
14.     ReDim oVertexs(n - 1)
15.    
16.     Dim oVlax As New VLAX
17.     lst = oVlax.GetLispList("(GetVers """ & Ent.Handle & """)")
18.    
19.     For i = 1 To n
20.         Set oVertexs(i - 1) = ThisDrawing.HandleToObject(lst(n - i))
21.     Next i
22.    
23.     GetVertexs = oVertexs
24.    
25. End Function
26. Sub test4()
27.     On Error Resume Next
28.    
29.     Dim obj As AcadEntity, pnt, oVers
30.     Dim xt, xd
31.    
32.     ThisDrawing.Utility.GetEntity obj, pnt
33.    
34.     oVers = GetVertexs(obj)
35.     If oVers <> vbEmpty Then
36.         For i = 0 To UBound(oVers)
37.             s = ""
38.             oVers(i).GetXData "", xt, xd
39.             
40.             For j = 0 To UBound(xd)
41.                 s = s & vbCrLf & xd(j)
42.             Next j
43.             If Err Then
44.                 Err.Clear
45.                 MsgBox "空值"
46.             Else
47.                 MsgBox s
48.             End If
49.         Next i
50.     Else
51.         MsgBox "错误选择"
52.     End If
53. End Sub

Function GetVertexs(Ent As AcadEntity) As Variant     Dim n As Integer     Dim oVertexs() As AcadObject     Dim sName As String     sName = UCase(Ent.ObjectName)         If sName = "ACDB2DPOLYLINE" Or sName = "ACDB3DPOLYLINE" Then         n = (UBound(Ent.Coordinates) + 1) / 3     End If         If n = 0 Then Exit Function         ReDim oVertexs(n - 1)         Dim oVlax As New VLAX     lst = oVlax.GetLispList("(GetVers """ & Ent.Handle & """)")         For i = 1 To n         Set oVertexs(i - 1) = ThisDrawing.HandleToObject(lst(n - i))     Next i         GetVertexs = oVertexs     End Function Sub test4()     On Error Resume Next         Dim obj As AcadEntity, pnt, oVers     Dim xt, xd         ThisDrawing.Utility.GetEntity obj, pnt         oVers = GetVertexs(obj)     If oVers <> vbEmpty Then         For i = 0 To UBound(oVers)             s = ""             oVers(i).GetXData "", xt, xd                          For j = 0 To UBound(xd)                 s = s & vbCrLf & xd(j)             Next j             If Err Then                 Err.Clear                 MsgBox "空值"             Else                 MsgBox s             End If         Next i     Else         MsgBox "错误选择"     End If End Sub

Lisp代码

2. (defun getvers(handle / lst ver)
3. (setq ver (handent handle))
4. (while (and (setq ver (entnext ver)) (= "VERTEX" (cdr (assoc 0 (entget ver)))))(setq lst (cons (cdr (assoc 5 (entget ver))) lst)))
5. lst
6. )

(defun getvers(handle / lst ver) (setq ver (handent handle)) (while (and (setq ver (entnext ver)) (= "VERTEX" (cdr (assoc 0 (entget ver)))))(setq lst (cons (cdr (assoc 5 (entget ver))) lst))) lst )

lihengmin

我安装的是CAD2004，当执行GetVertexs过程时出现错误“用户定义类型未定义” 原因是下面的语句

Dim oVlax As New VLAX

麻烦您指点