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

lihengmin 发表于 2007-12-22 20:34:00

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

雪山飞狐_lzh 发表于 2007-12-23 16:42:00

发图上来看看

lihengmin 发表于 2007-12-24 13:16:00

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

雪山飞狐_lzh 发表于 2007-12-24 13:47:00

本帖最后由作者于 2007-12-24 13:58:01 编辑 命令: 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 发表于 2007-12-24 22:01:00

谢谢您，这些俺也能读，还有，每个线段上也有相应的扩展属性，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 发表于 2007-12-25 11:52:00

CASS把Ｘｄａｔａ放在Vertex对象了，而ＶＢＡ的对象模型没有提供该对象
可以将多段线的handle依次循环加一，再调用HandleToObject获得该对象
如你的例图的Handle为464
用Set oVertex1 = ThisDrawing.HandleToObject("466")获得第二个Vertex对象，再调用GetXData
测试代码
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 发表于 2007-12-25 13:10:00

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

雪山飞狐_lzh 发表于 2007-12-25 13:29:00

那就用Vlax类吧

雪山飞狐_lzh 发表于 2007-12-25 15:36:00

VBA代码
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 SubLisp代码
(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 发表于 2007-12-25 21:49:00

我安装的是CAD2004，当执行GetVertexs过程时出现错误“用户定义类型未定义” 原因是下面的语句Dim oVlax As New VLAX麻烦您指点

页: [1] 2

明经CAD社区's Archiver

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