如何获取VERTEX子实体所附带的扩展属性
如何获取VERTEX子实体所附带的扩展属性 <p>VERTEX子实体没有在对象模型中公开，以前试过读取它，好像数据可以读出来，</p><p>方法读取pl线的句柄，然后获取此句柄后的实体</p><p>不确定是否可以成功，因为是很久以前试过的</p> 我也很想知道，不知道哪位高手能给个答案？ <p>终于找到答案了，真费劲啊。</p><p>CASS下通过VBA获取子对象的扩展属性<br/>(2008-05-22 09:54:47)<br/>转载<br/>标签：<br/>it<br/> 分类：GIS二次开发<br/>背景：<br/> CASS中，录入界址线属性时，一宗地的所有界址线本宗指界人和指界日期是一样的，但就现状来说，如一宗地有4条界址线，本宗指界人和指界日期就要录入4遍，能否只录入一遍，其余界址线的本宗指界人和指界日期自动产生。<br/> 基于此目的，书写以下程序：<br/>版本信息：AutoCAD 2006、CASS7.1<br/>关键技术：<br/> 在CASS中，二维多段线是一个复杂实体，除了主实体之外还带有子实体（VERTEX），界址线的属性就存储在VERTEX中，关键是要获取子实体。<br/> <br/>1、把以下LISP代码复制到acad2006doc.lsp中：<br/>(defun getvers(handle / lst ver)<br/>(setq ver (handent handle))<br/>(while (and (setq ver (entnext ver)) (= "VERTEX" (cdr (assoc 0 (entget ver)))))(setq lst (cons (cdr (assoc 5 (entget ver))) lst)))<br/>lst<br/>)<br/> <br/>位置在<br/>;; Silent load.<br/>(princ)<br/>上。<br/>2、新建一个VLAX类，并把以下代码复制到其中。</p><p>' VLAX.CLS v2.0 (Last updated 8/1/2003)<br/>' Copyright 1999-2001 by Frank Oquendo<br/>'<br/>' 该程序由明经通道修改支持2004版本<br/>' <a href="http://www.mjtd.com">http://www.mjtd.com</a><br/>'<br/>' Permission to use, copy, modify, and distribute this software<br/>' for any purpose and without fee is hereby granted, provided<br/>' that the above copyright notice appears in all copies and<br/>' that both that copyright notice and the limited warranty and<br/>' restricted rights notice below appear in all supporting<br/>' documentation.<br/>'<br/>' FRANK OQUENDO (THE AUTHOR) PROVIDES THIS PROGRAM "AS IS" AND WITH<br/>' ALL FAULTS. THE AUTHOR SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY<br/>' OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE. THE AUTHOR<br/>' DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE<br/>' UNINTERRUPTED OR ERROR FREE.<br/>'<br/>' Use, duplication, or disclosure by the U.S. Government is subject to<br/>' restrictions set forth in FAR 52.227-19 (Commercial Computer<br/>' Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)<br/>' (Rights in Technical Data and Computer Software), as applicable.<br/>'<br/>' VLAX.cls allows developers to evaluate AutoLISP expressions from<br/>' Visual Basic or VBA<br/>'<br/>' Notes:<br/>' All code for this class module is publicly available througout various posts<br/>' at <a href="news://discussion.autodesk.com/autodesk.autocad.customization.vba">news://discussion.autodesk.com/autodesk.autocad.customization.vba</a>. I do not<br/>' claim copyright or authorship on code presented in these posts, only on this<br/>' compilation of that code. In addition, a great big "Thank you!" to Cyrille Fauvel<br/>' demonstrating the use of the VisualLISP ActiveX Module.<br/>'<br/>' Dependencies:<br/>' Use of this class module requires the following application:<br/>' 1. VisualLISP<br/>Private VL As Object<br/>Private VLF As Object<br/>Private Sub Class_Initialize()<br/> If Left(ThisDrawing.Application.Version, 2) = "15" Then<br/> Set VL = GetInterfaceObject("VL.Application.1")<br/> ElseIf Left(ThisDrawing.Application.Version, 2) = "16" Then<br/> Set VL = GetInterfaceObject("VL.Application.16")<br/> ElseIf Left(ThisDrawing.Application.Version, 2) = "17" Then<br/> Set VL = GetInterfaceObject("VL.Application.16")<br/> End If<br/> Set VLF = VL.ActiveDocument.Functions<br/>End Sub<br/>Private Sub Class_Terminate()<br/> Set VLF = Nothing<br/> Set VL = Nothing<br/>End Sub<br/>Public Function EvalLispexpression_r(ByVal lispStatement As String)<br/> Dim sym As Object, RET As Object, RetVal<br/> <br/> Set sym = VLF.Item("read").Funcall(lispStatement)<br/> On Error Resume Next<br/> RetVal = VLF.Item("eval").Funcall(sym)<br/> If Err Then<br/> EvalLispExpression = ""<br/> Else<br/> EvalLispExpression = RetVal<br/> End If<br/>End Function<br/>Public Sub SetLispSymbol(ByVal symbolName As String, ByVal Value)<br/> Dim sym As Object, RET, symvalue<br/> <br/> symvalue = Value<br/> Set sym = VLF.Item("read").Funcall(symbolName)<br/> RET = VLF.Item("set").Funcall(sym, symvalue)<br/> EvalLispExpression "(defun translate-variant (data) (cond ((= (type data) 'list) (mapcar 'translate-variant data)) ((= (type data) 'variant) (translate-variant (vlax-variant-value data))) ((= (type data) 'safearray) (mapcar 'translate-variant (vlax-safearray->list data))) (t data)))"<br/> EvalLispExpression "(setq " & symbolName & "(translate-variant " & symbolName & "))"<br/> EvalLispExpression "(setq translate-variant nil)"<br/>End Sub<br/>Public Function GetLispSymbol(ByVal symbolName As String)<br/> Dim sym As Object, RET, symvalue<br/> <br/> symvalue = Value<br/> Set sym = VLF.Item("read").Funcall(symbolName)<br/> GetLispSymbol = VLF.Item("eval").Funcall(sym)<br/>End Function<br/>Public Function GetLispList(ByVal symbolName As String) As Variant<br/> Dim sym As Object, list As Object<br/> Dim Count, elements(), i As Long<br/> <br/> Set sym = VLF.Item("Read").Funcall(symbolName)<br/> Set list = VLF.Item("Eval").Funcall(sym)<br/> <br/> Count = VLF.Item("length").Funcall(list)<br/> <br/> ReDim elements(0 To Count - 1) As Variant<br/> <br/> For i = 0 To Count - 1<br/> elements(i) = VLF.Item("nth").Funcall(i, list)<br/> Next<br/> <br/> GetLispList = elements<br/> <br/>End Function<br/>Public Sub NullifySymbol(ParamArray symbolName())<br/> Dim i As Integer<br/> <br/> For i = LBound(symbolName) To UBound(symbolName)<br/> EvalLispExpression "(setq " & CStr(symbolName(i)) & " nil)"<br/> Next<br/>End Sub</p><p><br/>3、新建一个函数(获取子实体)</p><p><br/>Function GetVertexs(Ent As AcadEntity) As Variant<br/> Dim n As Integer<br/> Dim oVertexs() As AcadObject<br/> Dim sName As String<br/> sName = UCase(Ent.ObjectName)<br/> <br/> If sName = "ACDB2DPOLYLINE" Or sName = "ACDB3DPOLYLINE" Then<br/> n = (UBound(Ent.Coordinates) + 1) / 3<br/> End If<br/> <br/> If n = 0 Then Exit Function<br/> <br/> ReDim oVertexs(n - 1)<br/> <br/> Dim oVlax As New VLAX<br/> lst = oVlax.GetLispList("(GetVers """ & Ent.Handle & """)")<br/> <br/> For i = 1 To n<br/> Set oVertexs(i - 1) = ThisDrawing.HandleToObject(lst(n - i))<br/> Next i<br/> <br/> GetVertexs = oVertexs<br/> <br/>End Function</p><p> </p><p>4、新建一个过程(获取扩展属性)</p><p>Sub test4()<br/> On Error Resume Next<br/> <br/> Dim obj As AcadEntity, pnt, oVers<br/> Dim xt, xd<br/> <br/> ThisDrawing.Utility.GetEntity obj, pnt, "请选择界址线所在的宗地："<br/> <br/> oVers = GetVertexs(obj)<br/> If oVers <> vbEmpty Then<br/> For i = 0 To UBound(oVers)<br/> s = ""<br/> oVers(i).GetXData "", xt, xd<br/> <br/> For j = 0 To UBound(xd)<br/> s = s & vbCrLf & xd(j)<br/> Next j<br/> If Err Then<br/> Err.Clear<br/> MsgBox "空值"<br/> Else<br/> MsgBox s<br/> End If<br/> Next i<br/> Else<br/> MsgBox "错误选择"<br/> End If<br/>End Sub</p><p> </p><p>注意：新建一个Public WithEvents PLine as AcadPolyline(即给polyline加入一个事件)。</p><p>This event will be triggered whenever the object is modified. Modification includes whenever the value of a property is set, even if the new value is equal to the current value.</p><p>When coding in VBA, you must provide an event handler for all objects enabled for the Modified event. If you do not provide a handler, VBA may terminate unexpectedly.</p><p>No events will be fired while a modal dialog is being displayed.</p><p>然后把获取扩展属性的代码放在Modified内部即可达到目的。</p> <p>这是老版本的2维线呀，采用这种方法，cass就没有进步的可能了。</p> 是啊，在大比例尺制图软件方面cass还有些市场。在中小比例尺方面cass很难进入啊！
页:
[1]