vba/vb取得autocad对象的组码对应值

zzyong00

众所周知，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对象的组码对应值成为可能！经过我多次测试，把代码写出来，看起来也非常简单：

1. '工程中加载vlax.cls,如没有可从明经通道可以下载到
   
2. ''By zzyong00
   
3. ''2015.04.26
   
4. Public Function GetEntDxf(ByVal handle As String, ByVal DxfCode As Long)
   
5.     Dim objVLAX As VLAX
   
6.     Set objVLAX = New VLAX
   
7.     Dim retval
   
8.     With objVLAX
   
9.         '.EvalLispExpression "(setq retval (cdr (assoc '" & DxfCode & " (entget (handent " & Chr(34) & handle & Chr(34) & ")))))"
   
10.         .SetLispSymbol "handle", handle
    
11.         .EvalLispExpression "(setq retval (cdr (assoc '" & DxfCode & " (entget (handent handle)))))"
    
12.         retval = .GetLispSymbol("retval")
    
13.         .NullifySymbol "handle", "retval"
    
14.     End With
    
15.     GetEntDxf = retval
    
16. End Function
    

'工程中加载vlax.cls,如没有可从明经通道可以下载到<br /> ''By zzyong00<br /> ''2015.04.26<br /> Public Function GetEntDxf(ByVal handle As String, ByVal DxfCode As Long)<br />     Dim objVLAX As VLAX<br />     Set objVLAX = New VLAX<br />     Dim retval<br />     With objVLAX<br />         '.EvalLispExpression "(setq retval (cdr (assoc '" & DxfCode & " (entget (handent " & Chr(34) & handle & Chr(34) & ")))))"<br />         .SetLispSymbol "handle", handle<br />         .EvalLispExpression "(setq retval (cdr (assoc '" & DxfCode & " (entget (handent handle)))))"<br />         retval = .GetLispSymbol("retval")<br />         .NullifySymbol "handle", "retval"<br />     End With<br />     GetEntDxf = retval<br /> End Function<br />

调用以上GetEntDxf，获取wipeout的边框是否显示：

1. Dim d As AcadObject
   
2. Dim obj As AcadObject
   
3.     For Each d In ThisDrawing.Dictionaries
   
4.         If d.ObjectName = "AcDbWipeoutVariables" Then
   
5.             Set obj = d
   
6. '            Debug.Print obj.handle
   
7.             Exit For
   
8.         End If
   
9.     Next
   
10.     If obj Is Nothing Then Exit Sub
    
11.     Dim ret1 As Long
    
12.     ret1 = CLng(GetEntDxf(obj.handle, 70))‘取得组码为70对应的值
    
13.     MsgBox ret1
    

Dim d As AcadObject<br /> Dim obj As AcadObject<br />     For Each d In ThisDrawing.Dictionaries<br />         If d.ObjectName = "AcDbWipeoutVariables" Then<br />             Set obj = d<br /> '            Debug.Print obj.handle<br />             Exit For<br />         End If<br />     Next<br />     If obj Is Nothing Then Exit Sub<br />     Dim ret1 As Long<br />     ret1 = CLng(GetEntDxf(obj.handle, 70))‘取得组码为70对应的值<br />     MsgBox ret1<br />

GetEntDxf只能用于组码对应值为一个简单值的情况，如组码对应值为关联表，哪就不行。而在我实际测试过程中，发现vlax.cls也无法对返回值为关联表的函数正确执行，找了很多资料，都没能解决！如下面代码，是设置AcDbWipeoutVariables的70组码值为1的，用到subst 和entmod,都返回关联表的，用vlax.cls始终无法正确执行！好在这里不需要返回值，于是就用sendcommand了

1. Dim d As AcadObject
   
2. Dim obj As AcadObject
   
3.     For Each d In ThisDrawing.Dictionaries
   
4.         If d.ObjectName = "AcDbWipeoutVariables" Then
   
5.             Set obj = d
   
6. '            Debug.Print obj.handle
   
7.             Exit For
   
8.         End If
   
9.     Next
   
10.     If obj Is Nothing Then Exit Sub
    
11.     ThisDrawing.SendCommand "(entmod (subst '(" & "70" & " . " & "1" & ") (assoc " & "70" & " (entget (handent " & Chr(34) & obj.handle & Chr(34) & "))) (entget (handent " & Chr(34) & obj.handle & Chr(34) & ")))) "
    
12.     ThisDrawing.Regen acAllViewports
    

Dim d As AcadObject<br /> Dim obj As AcadObject<br />     For Each d In ThisDrawing.Dictionaries<br />         If d.ObjectName = "AcDbWipeoutVariables" Then<br />             Set obj = d<br /> '            Debug.Print obj.handle<br />             Exit For<br />         End If<br />     Next<br />     If obj Is Nothing Then Exit Sub<br />     ThisDrawing.SendCommand "(entmod (subst '(" & "70" & " . " & "1" & ") (assoc " & "70" & " (entget (handent " & Chr(34) & obj.handle & Chr(34) & "))) (entget (handent " & Chr(34) & obj.handle & Chr(34) & ")))) "<br />     ThisDrawing.Regen acAllViewports<br />

本人写个帖子，是由于这个同学的启示而写的：http://bbs.mjtd.com/thread-113374-1-1.html

希望能对他也有点帮助！

zzyong00

另外，本论坛的efan2000给出了用LastPrompt系统变量取组码的方法！
http://bbs.mjtd.com/forum.php?mo ... 9897&pid=101902

lennie

lennie

程序精简了一下：

2. Public Function WipeOutFrame() As Boolean     '返回wipout边界是否打开的状态，打开返回True
   
3.     Dim obj As Object
   
4.     For Each obj In ThisDrawing.Dictionaries
   
5.         If obj.ObjectName = "AcDbWipeoutVariables" Then
   
6.             WipeOutFrame = CBool(GetDXFCodeValue(obj, 70))
   
7.         End If
   
8.     Next
   
9. End Function

Public Function WipeOutFrame() As Boolean     '返回wipout边界是否打开的状态，打开返回True<br />     Dim obj As Object<br />     For Each obj In ThisDrawing.Dictionaries<br />         If obj.ObjectName = "AcDbWipeoutVariables" Then<br />             WipeOutFrame = CBool(GetDXFCodeValue(obj, 70))<br />         End If<br />     Next<br /> End Function

这里用到一个修改后的函数 GetDXFCodeValue：

2. Public Function GetDXFCodeValue(Ent As Object, gCode As Integer) As Variant
   
3.     Dim retval
   
4.     Dim obj As New CL
   
5.         retval = obj.EvalLispExpression("(cdr (assoc " & gCode & " (entget (handent " & Chr(34) & Ent.Handle & Chr(34) & "))))")
   
6.         GetDXFCodeValue = retval
   
7.         Set obj = Nothing
   
8. End Function

Public Function GetDXFCodeValue(Ent As Object, gCode As Integer) As Variant<br />     Dim retval<br />     Dim obj As New CL<br />         retval = obj.EvalLispExpression("(cdr (assoc " & gCode & " (entget (handent " & Chr(34) & Ent.Handle & Chr(34) & "))))")<br />         GetDXFCodeValue = retval<br />         Set obj = Nothing<br /> End Function

另外，用SendCommand的方法命令窗口会跳出一堆文字，毕竟不美观。以下是我来获取天正对象坐标（组码10）的函数：

2. Function GetDxfPoint(Ent As Object, gCode As Integer) As Variant
   
3.     Select Case TypeName(Ent)
   
4.         Case "IComSymbElev", "IComLineText", "IComSpace"
   
5.             Dim retval
   
6.             Dim aPoint(2) As Double
   
7.             Dim obj As New CL
   
8.             retval = obj.EvalLispExpression("(car(cdr (assoc " & gCode & " (entget (handent " & Chr(34) & Ent.Handle & Chr(34) & ")))))")
   
9.             aPoint(0) = retval
   
10.             retval = obj.EvalLispExpression("(car (cdr (cdr (assoc " & gCode & " (entget (handent " & Chr(34) & Ent.Handle & Chr(34) & "))))))")
    
11.             aPoint(1) = retval
    
12.             retval = obj.EvalLispExpression("(car (cdr (cdr (cdr (assoc " & gCode & " (entget (handent " & Chr(34) & Ent.Handle & Chr(34) & ")))))))")
    
13.             aPoint(2) = retval
    
14.             GetDxfPoint = aPoint
    
15.             Set obj = Nothing
    
16.         Case "IAcadText", "IAcadMText"
    
17.             GetDxfPoint = Ent.InsertionPoint
    
18.     End Select
    
19. End Function

Function GetDxfPoint(Ent As Object, gCode As Integer) As Variant<br />     Select Case TypeName(Ent)<br />         Case "IComSymbElev", "IComLineText", "IComSpace"<br />             Dim retval<br />             Dim aPoint(2) As Double<br />             Dim obj As New CL<br />             retval = obj.EvalLispExpression("(car(cdr (assoc " & gCode & " (entget (handent " & Chr(34) & Ent.Handle & Chr(34) & ")))))")<br />             aPoint(0) = retval<br />             retval = obj.EvalLispExpression("(car (cdr (cdr (assoc " & gCode & " (entget (handent " & Chr(34) & Ent.Handle & Chr(34) & "))))))")<br />             aPoint(1) = retval<br />             retval = obj.EvalLispExpression("(car (cdr (cdr (cdr (assoc " & gCode & " (entget (handent " & Chr(34) & Ent.Handle & Chr(34) & ")))))))")<br />             aPoint(2) = retval<br />             GetDxfPoint = aPoint<br />             Set obj = Nothing<br />         Case "IAcadText", "IAcadMText"<br />             GetDxfPoint = Ent.InsertionPoint<br />     End Select<br /> End Function

lennie

找到这个字典以后，监视窗口里对象居然是空白的。

VB局限性太大了，而且64位CAD的话原来做的Dll文件都不能用了。好处是采用后绑定的方法可以通吃多个CAD版本。这里要鄙视微软，鄙视自动桌子。

zzyong00

现在用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

lennie 发表于 2015-4-29 14:38
找到这个字典以后，监视窗口里对象居然是空白的。

VB局限性太大了，而且64位CAD的话原来做的Dll文件都 ...

dll里面涉及object对象作为参数传递 基本上都有问题。

zzyong00

http://bbs.mjtd.com/thread-111871-1-1.html
你看看我哪个帖子里的dll，就是传对象进去，一点问题没有

zzyong00

还有这个http://bbs.mjtd.com/thread-113517-1-1.html

yyzhan12

'工程中加载vlax.cls,如没有可从明经通道可以下载到
''By zzyong00
''2015.04.26

方便给出vlax.cls的下载链接吗？没搜索