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

雪山飞狐_lzh

把下面的代码放到VLAX类代码里

3. ' VLAX.CLS v2.0 (Last updated 8/1/2003)
4. ' Copyright 1999-2001 by Frank Oquendo
5. '
6. ' 该程序由明经通道修改支持2004版本
7. ' http://www.mjtd.com
8. '
9. ' Permission to use, copy, modify, and distribute this software
10. ' for any purpose and without fee is hereby granted, provided
11. ' that the above copyright notice appears in all copies and
12. ' that both that copyright notice and the limited warranty and
13. ' restricted rights notice below appear in all supporting
14. ' documentation.
15. '
16. ' FRANK OQUENDO (THE AUTHOR) PROVIDES THIS PROGRAM "AS IS" AND WITH
17. ' ALL FAULTS. THE AUTHOR SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY
18. ' OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  THE AUTHOR
19. ' DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
20. ' UNINTERRUPTED OR ERROR FREE.
21. '
22. ' Use, duplication, or disclosure by the U.S. Government is subject to
23. ' restrictions set forth in FAR 52.227-19 (Commercial Computer
24. ' Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
25. ' (Rights in Technical Data and Computer Software), as applicable.
26. '
27. ' VLAX.cls allows developers to evaluate AutoLISP expressions from
28. ' Visual Basic or VBA
29. '
30. ' Notes:
31. ' All code for this class module is publicly available througout various posts
32. ' at news://discussion.autodesk.com/autodesk.autocad.customization.vba. I do not
33. ' claim copyright or authorship on code presented in these posts, only on this
34. ' compilation of that code. In addition, a great big "Thank you!" to Cyrille Fauvel
35. ' demonstrating the use of the VisualLISP ActiveX Module.
36. '
37. ' Dependencies:
38. ' Use of this class module requires the following application:
39. ' 1. VisualLISP
40. Private VL As Object
41. Private VLF As Object
42. Private Sub Class_Initialize()
43.     If Left(ThisDrawing.Application.Version, 2) = "15" Then
44.      Set VL = GetInterfaceObject("VL.Application.1")
45.     ElseIf Left(ThisDrawing.Application.Version, 2) = "16" Then
46.      Set VL = GetInterfaceObject("VL.Application.16")
47.     ElseIf Left(ThisDrawing.Application.Version, 2) = "17" Then
48.      Set VL = GetInterfaceObject("VL.Application.16")
49.     End If
50.     Set VLF = VL.ActiveDocument.Functions
51. End Sub
52. Private Sub Class_Terminate()
53.     Set VLF = Nothing
54.     Set VL = Nothing
55. End Sub
56. Public Function EvalLispExpression(ByVal lispStatement As String)
57.     Dim sym As Object, RET As Object, RetVal
58.    
59.     Set sym = VLF.Item("read").funcall(lispStatement)
60.     On Error Resume Next
61.     RetVal = VLF.Item("eval").funcall(sym)
62.     If Err Then
63.         EvalLispExpression = ""
64.     Else
65.         EvalLispExpression = RetVal
66.     End If
67. End Function
68. Public Sub SetLispSymbol(ByVal symbolName As String, ByVal Value)
69.     Dim sym As Object, RET, symvalue
70.    
71.     symvalue = Value
72.     Set sym = VLF.Item("read").funcall(symbolName)
73.     RET = VLF.Item("set").funcall(sym, symvalue)
74.     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)))"
75.     EvalLispExpression "(setq " & symbolName & "(translate-variant " & symbolName & "))"
76.     EvalLispExpression "(setq translate-variant nil)"
77. End Sub
78. Public Function GetLispSymbol(ByVal symbolName As String)
79.     Dim sym As Object, RET, symvalue
80.    
81.     symvalue = Value
82.     Set sym = VLF.Item("read").funcall(symbolName)
83.     GetLispSymbol = VLF.Item("eval").funcall(sym)
84. End Function
85. Public Function GetLispList(ByVal symbolName As String) As Variant
86.    Dim sym As Object, list As Object
87.    Dim Count, elements(), i As Long
88.    
89.    Set sym = VLF.Item("read").funcall(symbolName)
90.    Set list = VLF.Item("eval").funcall(sym)
91.    
92.    Count = VLF.Item("length").funcall(list)
93.    
94.    ReDim elements(0 To Count - 1) As Variant
95.    
96.    For i = 0 To Count - 1
97.         elements(i) = VLF.Item("nth").funcall(i, list)
98.    Next
99.    
100.    GetLispList = elements
101.    
102. End Function
103. Public Sub NullifySymbol(ParamArray symbolName())
104.     Dim i As Integer
105.    
106.     For i = LBound(symbolName) To UBound(symbolName)
107.         EvalLispExpression "(setq " & CStr(symbolName(i)) & " nil)"
108.     Next
109. End Sub

' 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(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

lihengmin

导入了VLAX.CLS类，

Dim VL As New VLAX　

Private Sub Class_Initialize()
    If Left(ThisDrawing.Application.Version, 2) = "15" Then
        Set VL = ThisDrawing.Application.GetInterfaceObject("VL.Application.1")
    ElseIf Left(ThisDrawing.Application.Version, 2) = "16" Then
        Set VL = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
    End If
    Set VLF = VL.ActiveDocument.Functions
End Sub

运行到此处总是跳转到错误处理语句？！不知道如何解决。我用的是CAD2004中文版

雪山飞狐_lzh

新建一个类模块，把名字改成Vlax

再把１１楼的代码Ｃｏｐｙ进去

lihengmin

对啊，我考进去了，但每次选择后提示“错误选择”

后我把错误处理的去掉后再运行

到Set VL = GetInterfaceObject("VL.Application.16")出错“运行时错误－2147220999（800401放）：加载应用程序时出现问题”
    

lihengmin

对了，9楼的LIST代码我没用，还要用他吗？麻烦您指点

lihengmin

(vl-load-com)

运行上面的语句已基本可以了，谢谢您 

lihengmin

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

当运行到上面标颜色的语句时出现如下错误：

运行时错误 2000
no function definition: GETVERS

雪山飞狐_lzh

lisp代码放在acad2004doc.lsp文件里

lihengmin

十分感谢您的指点，我的QQ106130523，希望能继续得到您的帮助

yxr_MJTD

雪山飞狐_lzh 发表于 2007-12-25 11:52
CASS把Ｘｄａｔａ放在Vertex对象了，而ＶＢＡ的对象模型没有提供该对象
可以将多段线的handle依次循环加一， ...

飞狐,请问这个对应C# 应该怎么做呢？我没有查到相应的方法，我在网上也只查到这一条相关的信息。