|
终于找到答案了，真费劲啊。 CASS下通过VBA获取子对象的扩展属性
(2008-05-22 09:54:47)
转载
标签：
it
分类：GIS二次开发
背景：
CASS中，录入界址线属性时，一宗地的所有界址线本宗指界人和指界日期是一样的，但就现状来说，如一宗地有4条界址线，本宗指界人和指界日期就要录入4遍，能否只录入一遍，其余界址线的本宗指界人和指界日期自动产生。
基于此目的，书写以下程序：
版本信息：AutoCAD 2006、CASS7.1
关键技术：
在CASS中，二维多段线是一个复杂实体，除了主实体之外还带有子实体（VERTEX），界址线的属性就存储在VERTEX中，关键是要获取子实体。
1、把以下LISP代码复制到acad2006doc.lsp中：
(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
)
位置在
;; Silent load.
(princ)
上。
2、新建一个VLAX类，并把以下代码复制到其中。 ' VLAX.CLS v2.0 (Last updated 8/1/2003)
' Copyright 1999-2001 by Frank Oquendo
'
' 该程序由明经通道修改支持2004版本
' http://www.mjtd.com
'
' Permission to use, copy, modify, and distribute this software
' for any purpose and without fee is hereby granted, provided
' that the above copyright notice appears in all copies and
' that both that copyright notice and the limited warranty and
' restricted rights notice below appear in all supporting
' documentation.
'
' FRANK OQUENDO (THE AUTHOR) PROVIDES THIS PROGRAM "AS IS" AND WITH
' ALL FAULTS. THE AUTHOR SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY
' OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE. THE AUTHOR
' DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
' UNINTERRUPTED OR ERROR FREE.
'
' Use, duplication, or disclosure by the U.S. Government is subject to
' restrictions set forth in FAR 52.227-19 (Commercial Computer
' Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
' (Rights in Technical Data and Computer Software), as applicable.
'
' VLAX.cls allows developers to evaluate AutoLISP expressions from
' Visual Basic or VBA
'
' Notes:
' All code for this class module is publicly available througout various posts
' at news://discussion.autodesk.com/autodesk.autocad.customization.vba. I do not
' claim copyright or authorship on code presented in these posts, only on this
' compilation of that code. In addition, a great big "Thank you!" to Cyrille Fauvel
' demonstrating the use of the VisualLISP ActiveX Module.
'
' Dependencies:
' Use of this class module requires the following application:
' 1. VisualLISP
Private VL As Object
Private VLF As Object
Private Sub Class_Initialize()
If Left(ThisDrawing.Application.Version, 2) = "15" Then
Set VL = GetInterfaceObject("VL.Application.1")
ElseIf Left(ThisDrawing.Application.Version, 2) = "16" Then
Set VL = GetInterfaceObject("VL.Application.16")
ElseIf Left(ThisDrawing.Application.Version, 2) = "17" Then
Set VL = GetInterfaceObject("VL.Application.16")
End If
Set VLF = VL.ActiveDocument.Functions
End Sub
Private Sub Class_Terminate()
Set VLF = Nothing
Set VL = Nothing
End Sub
Public Function EvalLispexpression_r(ByVal lispStatement As String)
Dim sym As Object, RET As Object, RetVal
Set sym = VLF.Item("read").Funcall(lispStatement)
On Error Resume Next
RetVal = VLF.Item("eval").Funcall(sym)
If Err Then
EvalLispExpression = ""
Else
EvalLispExpression = RetVal
End If
End Function
Public Sub SetLispSymbol(ByVal symbolName As String, ByVal Value)
Dim sym As Object, RET, symvalue
symvalue = Value
Set sym = VLF.Item("read").Funcall(symbolName)
RET = VLF.Item("set").Funcall(sym, symvalue)
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)))"
EvalLispExpression "(setq " & symbolName & "(translate-variant " & symbolName & "))"
EvalLispExpression "(setq translate-variant nil)"
End Sub
Public Function GetLispSymbol(ByVal symbolName As String)
Dim sym As Object, RET, symvalue
symvalue = Value
Set sym = VLF.Item("read").Funcall(symbolName)
GetLispSymbol = VLF.Item("eval").Funcall(sym)
End Function
Public Function GetLispList(ByVal symbolName As String) As Variant
Dim sym As Object, list As Object
Dim Count, elements(), i As Long
Set sym = VLF.Item("Read").Funcall(symbolName)
Set list = VLF.Item("Eval").Funcall(sym)
Count = VLF.Item("length").Funcall(list)
ReDim elements(0 To Count - 1) As Variant
For i = 0 To Count - 1
elements(i) = VLF.Item("nth").Funcall(i, list)
Next
GetLispList = elements
End Function
Public Sub NullifySymbol(ParamArray symbolName())
Dim i As Integer
For i = LBound(symbolName) To UBound(symbolName)
EvalLispExpression "(setq " & CStr(symbolName(i)) & " nil)"
Next
End Sub
3、新建一个函数(获取子实体)
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
4、新建一个过程(获取扩展属性) 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 注意：新建一个Public WithEvents PLine as AcadPolyline(即给polyline加入一个事件)。 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. 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. No events will be fired while a modal dialog is being displayed. 然后把获取扩展属性的代码放在Modified内部即可达到目的。 | 
发表于 2009-5-13 16:42:00
置顶卡
变色卡
显身卡
发表于 2009-5-15 07:33:00