[求助]怎样用VBA读取CASS软件内每个界址线段的扩展属性 - VBA/VB/ActiveX/API 编程技术 - AutoCAD论坛 - 明经CAD社区 - 第2页

雪山飞狐_lzh 发表于 2007-12-25 22:03:00

把下面的代码放到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(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 发表于 2007-12-25 23:21:00

导入了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 发表于 2007-12-25 23:28:00

新建一个类模块，把名字改成Vlax再把１１楼的代码Ｃｏｐｙ进去

lihengmin 发表于 2007-12-25 23:42:00

对啊，我考进去了，但每次选择后提示“错误选择”后我把错误处理的去掉后再运行到Set VL = GetInterfaceObject("VL.Application.16")出错“运行时错误－2147220999（800401放）：加载应用程序时出现问题”

lihengmin 发表于 2007-12-26 00:17:00

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

lihengmin 发表于 2007-12-26 02:03:00

(vl-load-com)运行上面的语句已基本可以了，谢谢您

lihengmin 发表于 2007-12-26 02:24:00

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 发表于 2007-12-26 10:13:00

lisp代码放在acad2004doc.lsp文件里

lihengmin 发表于 2007-12-26 13:19:00

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

yxr_MJTD 发表于 2015-1-21 11:34:47

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

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

页: 1 [2]

明经CAD社区's Archiver