vba/vb取得autocad对象的组码对应值
本帖最后由 zzyong00 于 2015-4-26 01:02 编辑众所周知，vba/vb6二次开发autocad插件，都是基于autocad的对象模型，对象模型中给出大部分autocad的对象类型，但并不是全部，比如，有个对象是AcDbWipeoutVariables，vba中没有给出对应的对象，而它的70组码控制着wipeout的边框是否显示，在autocad2013以后的版本，有一个系统变量WIPEOUTFRAME控制着wipeout的边框是否显示，但在autocad2013以前的版本，却没有这个变量。用vba编程时，很难知道当前图的wipeout边框是否显示！但用lisp却很容易知道，详见：http://bbs.xdcad.net/thread-4040-1-1.html,造成这个问题的关键原因是，vba不能直接获取对象的组码值。用vba编写autocad插件,一般很少用到组码，只有选择实体时能用到，还有就是getxdata和setxdata函数，可以获取和设置1000以上组码值。而对于选择，autocad只能选择实体，像AcDbWipeoutVariables，属于词典类型（但不能把赋值给dictionary类型的变量），无法选择！也就是说，无法通过选择来判断组码的值！用vba/vb做这事儿，真是无能为力（我认为）！好在，有vlax.cls类，使得vba/vb可以调用lisp，这使得vba/vb取得autocad对象的组码对应值成为可能！经过我多次测试，把代码写出来，看起来也非常简单：
'工程中加载vlax.cls,如没有可从明经通道可以下载到
''By zzyong00
''2015.04.26
Public Function GetEntDxf(ByVal handle As String, ByVal DxfCode As Long)
Dim objVLAX As VLAX
Set objVLAX = New VLAX
Dim retval
With objVLAX
'.EvalLispExpression "(setq retval (cdr (assoc '" & DxfCode & " (entget (handent " & Chr(34) & handle & Chr(34) & ")))))"
.SetLispSymbol "handle", handle
.EvalLispExpression "(setq retval (cdr (assoc '" & DxfCode & " (entget (handent handle)))))"
retval = .GetLispSymbol("retval")
.NullifySymbol "handle", "retval"
End With
GetEntDxf = retval
End Function
调用以上GetEntDxf，获取wipeout的边框是否显示：
Dim d As AcadObject
Dim obj As AcadObject
For Each d In ThisDrawing.Dictionaries
If d.ObjectName = "AcDbWipeoutVariables" Then
Set obj = d
' Debug.Print obj.handle
Exit For
End If
Next
If obj Is Nothing Then Exit Sub
Dim ret1 As Long
ret1 = CLng(GetEntDxf(obj.handle, 70))‘取得组码为70对应的值
MsgBox ret1
GetEntDxf只能用于组码对应值为一个简单值的情况，如组码对应值为关联表，哪就不行。而在我实际测试过程中，发现vlax.cls也无法对返回值为关联表的函数正确执行，找了很多资料，都没能解决！如下面代码，是设置AcDbWipeoutVariables的70组码值为1的，用到subst 和entmod,都返回关联表的，用vlax.cls始终无法正确执行！好在这里不需要返回值，于是就用sendcommand了
Dim d As AcadObject
Dim obj As AcadObject
For Each d In ThisDrawing.Dictionaries
If d.ObjectName = "AcDbWipeoutVariables" Then
Set obj = d
' Debug.Print obj.handle
Exit For
End If
Next
If obj Is Nothing Then Exit Sub
ThisDrawing.SendCommand "(entmod (subst '(" & "70" & " . " & "1" & ") (assoc " & "70" & " (entget (handent " & Chr(34) & obj.handle & Chr(34) & "))) (entget (handent " & Chr(34) & obj.handle & Chr(34) & ")))) "
ThisDrawing.Regen acAllViewports
本人写个帖子，是由于这个同学的启示而写的：http://bbs.mjtd.com/thread-113374-1-1.html
希望能对他也有点帮助！
另外，本论坛的efan2000给出了用LastPrompt系统变量取组码的方法！
http://bbs.mjtd.com/forum.php?mod=redirect&goto=findpost&ptid=19897&pid=101902 本帖最后由 lennie 于 2015-4-29 14:32 编辑
程序精简了一下：Public Function WipeOutFrame() As Boolean '返回wipout边界是否打开的状态，打开返回True
Dim obj As Object
For Each obj In ThisDrawing.Dictionaries
If obj.ObjectName = "AcDbWipeoutVariables" Then
WipeOutFrame = CBool(GetDXFCodeValue(obj, 70))
End If
Next
End Function这里用到一个修改后的函数 GetDXFCodeValue：Public Function GetDXFCodeValue(Ent As Object, gCode As Integer) As Variant
Dim retval
Dim obj As New CL
retval = obj.EvalLispExpression("(cdr (assoc " & gCode & " (entget (handent " & Chr(34) & Ent.Handle & Chr(34) & "))))")
GetDXFCodeValue = retval
Set obj = Nothing
End Function另外，用SendCommand的方法命令窗口会跳出一堆文字，毕竟不美观。以下是我来获取天正对象坐标（组码10）的函数：Function GetDxfPoint(Ent As Object, gCode As Integer) As Variant
Select Case TypeName(Ent)
Case "IComSymbElev", "IComLineText", "IComSpace"
Dim retval
Dim aPoint(2) As Double
Dim obj As New CL
retval = obj.EvalLispExpression("(car(cdr (assoc " & gCode & " (entget (handent " & Chr(34) & Ent.Handle & Chr(34) & ")))))")
aPoint(0) = retval
retval = obj.EvalLispExpression("(car (cdr (cdr (assoc " & gCode & " (entget (handent " & Chr(34) & Ent.Handle & Chr(34) & "))))))")
aPoint(1) = retval
retval = obj.EvalLispExpression("(car (cdr (cdr (cdr (assoc " & gCode & " (entget (handent " & Chr(34) & Ent.Handle & Chr(34) & ")))))))")
aPoint(2) = retval
GetDxfPoint = aPoint
Set obj = Nothing
Case "IAcadText", "IAcadMText"
GetDxfPoint = Ent.InsertionPoint
End Select
End Function
找到这个字典以后，监视窗口里对象居然是空白的。
VB局限性太大了，而且64位CAD的话原来做的Dll文件都不能用了。好处是采用后绑定的方法可以通吃多个CAD版本。这里要鄙视微软，鄙视自动桌子。
本帖最后由 zzyong00 于 2015-4-29 14:49 编辑
现在用vlax.cls，可以读取实体的组码了，但是，修改实体组码时，还是会有一些问题，如以下lsp
"(entmod (subst '(" & "70" & " . " & "1" & ") (assoc " & "70" & " (entget (handent " & Chr(34) & obj.handle & Chr(34) & "))) (entget (handent " & Chr(34) & obj.handle & Chr(34) & ")))) "
就无法用vlax.cls执行，不得以只好用SendCommand了 lennie 发表于 2015-4-29 14:38 static/image/common/back.gif
找到这个字典以后，监视窗口里对象居然是空白的。
VB局限性太大了，而且64位CAD的话原来做的Dll文件都 ...
dll里面涉及object对象作为参数传递 基本上都有问题。 http://bbs.mjtd.com/thread-111871-1-1.html
你看看我哪个帖子里的dll，就是传对象进去，一点问题没有 还有这个http://bbs.mjtd.com/thread-113517-1-1.html '工程中加载vlax.cls,如没有可从明经通道可以下载到
''By zzyong00
''2015.04.26
方便给出vlax.cls的下载链接吗？没搜索
页:
[1]
2