[原创]命令行执行VBA程序，先选择后操作，透明命令

mccad

一直以来，我们都希望能找到一种简便的方法来实现VBA程序中的先选择后操作。
以前也提供过一种方法，见二次开发栏目的有关PickfirstSelectionSet方法的讨论 文章。
虽然以前提供过方法，但这种方法的缺点是：
1.过程复杂，要写个事件来触发，而且需要写个空的LISP程序来配合，这对一般用户来说有些难度，所以很多开发者最后都放弃使用先选择后操作(呵呵，包括我在内)。
2.这种方法存在BUG，这个BUG本身是AutoCAD的缺陷，而且直到2005都没有解决，看来Autodesk一直就对AX方法不太重视。这个BUG是，当所触发的程序都有对话框，而且对话框需要与AutoCAD交互(如隐藏对话框选择对象或点等操作)，当隐藏对话框后，屏幕中无法操作鼠标，只能使用键盘。
所以因为存在着这样的BUG，我写的那个“对象对齐与均布”的程序也没有使用这个功能(本来象那样的程序就需要可以先选择后操作)。

现在终于找到简单解决的方法，所以与大家分享。
大家都知道，使用LISP函数或AutoCAD命令来调用VBA过程，都会因为触发了其它命令而使PickfirstSelectionSet无法得到刚选定的选择集。但如果使用AX的RunMacro方法，则因为是AX方法，而不影响刚选定选择集的存在。对于VL来说，同样可以调用RunMacro方法，大家可以试试以下的LISP程序：

2. (defun C:VBARUNX ()
3.     (vl-load-com)
4.     (vla-runmacro
5.          (vlax-get-acad-object)
6.          (getstring "\n宏名称: ")
7.     )
8.     (princ)
9. )

(defun C:VBARUNX ()     (vl-load-com)     (vla-runmacro          (vlax-get-acad-object)          (getstring "\n宏名称: ")     )     (princ) )

运行后输入你需要运行的宏(过程)，格式为：DVB文件!模块名.过程名
呵呵，忘了给大家一个样例，将以下的程序保存为CC.DVB文件，注意放到支持目录下，这样就可以先选定图形中的一些对象，然后输入VBARUNX，在出现宏名称提示时输入CC.DVB!CC ，看看图形中的对象是不是变成绿色的。

2. Function PickFirstSSet() As AcadSelectionSet
3.     On Error Resume Next
4.     ThisDrawing.SelectionSets("PICKFIRST").Delete
5.     Set PickFirstSSet = ThisDrawing.PickfirstSelectionSet
6.     If PickFirstSSet.Count = 0 Then PickFirstSSet.SelectOnScreen
7. End Function
9. Sub CC()
10.     Dim Ent As AcadEntity
11.     Dim SS As AcadSelectionSet
12.     Set SS = PickFirstSSet
13.     For Each Ent In SS
14.         Ent.color = acGreen
15.     Next
16. End Sub

Function PickFirstSSet() As AcadSelectionSet     On Error Resume Next     ThisDrawing.SelectionSets("PICKFIRST").Delete     Set PickFirstSSet = ThisDrawing.PickfirstSelectionSet     If PickFirstSSet.Count = 0 Then PickFirstSSet.SelectOnScreen End Function Sub CC()     Dim Ent As AcadEntity     Dim SS As AcadSelectionSet     Set SS = PickFirstSSet     For Each Ent In SS         Ent.color = acGreen     Next End Sub

虽然已经找到了方法，我们就把上一次给大家的一个自动加载及执行VBA程序的函数改一下，变成兼容“先选择后操作”方式：

2. ;;自动加载VBA程序的函数
3. (defun AutoVBALoad (app cmdliste / qapp)
4.   (vl-load-com)
5.   (setq qapp (strcat """ app """))
6.   (mapcar
7.     '(lambda (cmd / nom_cmd dot nodotcmd)
8.        (progn
9.          (setq dot (vl-string-search "." cmd))
10.          (if dot
11.            (setq nodotcmd (substr cmd (+ dot 2)))
12.            (setq nodotcmd cmd)
13.          )
14.          (setq nom_cmd (strcat "C:" nodotcmd))
15.          (eval
16.            (read (strcat
17.                    "(defun " nom_cmd "(/ app)"
18.                      "(if (setq app(fdvbfile " qapp "))"
19.                        "(vla-runmacro (vlax-get-acad-object) (strcat app "!" cmd ""))"
20.                        "(nodvbfile " qapp "))"
21.                    "(princ ))"
22.        )))))
23.     cmdliste
24.   )
25.   (princ)
26. )
28. (defun fdvbfile (app)
29.   (if (not (findfile app))
30.     (if (not (findfile (strcat app ".dvb"))) nil  (strcat app ".dvb")) app)
31. )
32. (defun nodvbfile (filename)
33.   (princ (strcat "\n文件 " filename "(.dvb) 在搜索路径文件夹中未找到。" ))
34.   (princ "\n请检查支持文件的安装，然后重试。")
35.   (princ)
36. )

;;自动加载VBA程序的函数 (defun AutoVBALoad (app cmdliste / qapp)   (vl-load-com)   (setq qapp (strcat """ app """))   (mapcar     '(lambda (cmd / nom_cmd dot nodotcmd)        (progn          (setq dot (vl-string-search "." cmd))          (if dot            (setq nodotcmd (substr cmd (+ dot 2)))            (setq nodotcmd cmd)          )          (setq nom_cmd (strcat "C:" nodotcmd))          (eval            (read (strcat                    "(defun " nom_cmd "(/ app)"                      "(if (setq app(fdvbfile " qapp "))"                        "(vla-runmacro (vlax-get-acad-object) (strcat app "!" cmd ""))"                        "(nodvbfile " qapp "))"                    "(princ ))"        )))))     cmdliste   )   (princ) ) (defun fdvbfile (app)   (if (not (findfile app))     (if (not (findfile (strcat app ".dvb"))) nil  (strcat app ".dvb")) app) ) (defun nodvbfile (filename)   (princ (strcat "\n文件 " filename "(.dvb) 在搜索路径文件夹中未找到。" ))   (princ "\n请检查支持文件的安装，然后重试。")   (princ) )

这样刚才那个VBA过程就可以这样加载：

1. (AutoVBALoad "CC" '("cc"))

复制代码

好了，选定一些对象后，输入“CC”看看，是不是很简单。

顺便也给大家介绍一下“先选择后操作”在VBA中是怎样写选择集的，大家可以看到刚才的VBA程序中使用了一个自定义函数：

2. Function PickFirstSSet() As AcadSelectionSet
3.     On Error Resume Next
4.     ThisDrawing.SelectionSets("PICKFIRST").Delete
5.     Set PickFirstSSet = ThisDrawing.PickfirstSelectionSet
6.     If PickFirstSSet.Count = 0 Then PickFirstSSet.SelectOnScreen
7. End Function

Function PickFirstSSet() As AcadSelectionSet     On Error Resume Next     ThisDrawing.SelectionSets("PICKFIRST").Delete     Set PickFirstSSet = ThisDrawing.PickfirstSelectionSet     If PickFirstSSet.Count = 0 Then PickFirstSSet.SelectOnScreen End Function

这个函数包含了以下的功能：
1.生成选择集。
2.把用户已经选定的对象放在选择集中。
3.如果用户没有选定对象，则提示用户选择对象。
呵呵，就这么几行就可以解决这么多问题，而且还解决了选择集的BUG。这个BUG就不介绍了，论坛中已经介绍过好多次了。

大家在写程序过程中用这个函数来做选择。

mccad

这是以前的讨论链接：
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=4827
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=22987

mccad

既然先选择后操作在VBA中可以实现，我们就试一下让VBA程序变成透明命令。呵呵，这个想法在以前想都不敢想。
先试试前面的那个程序，在命令行中输入：
(vlax-add-cmd "cc" 'c:cc "cc" 3)
好了，然后用“'cc”的命令方式调用该VBA程序。不错，可以用了。
再试试在其它命令中调用，看来也没有问题吧。
可以说，我们已经成功了。
既然成功，我们就得想一个简单的方法来让这种实现，还是上面那个AutoVBALoad。就再改一下吧：

2. ;;自动加载VBA程序的函数
3.   (vl-load-com)
4. (defun AutoVBALoad (app cmdliste stat / qapp strcmd)
5.   (setq qapp (strcat """ app """))
6.   (mapcar
7.     '(lambda (cmd / nom_cmd dot nodotcmd)
8.        (progn
9.          (setq dot (vl-string-search "." cmd))
10.          (if dot
11.            (setq nodotcmd (substr cmd (+ dot 2)))
12.            (setq nodotcmd cmd)
13.          )
14.          (setq nom_cmd (strcat "C:" nodotcmd))
15.          (if (member stat '(0 1 2 3 4 5 6 7))
16.            (setq strcmd
17.                  (strcat"(vlax-add-cmd "" nodotcmd "" \'"
18.                         nom_cmd """ nodotcmd """ (itoa stat) " )"))
19.            (setq strcmd "")
20.          )
21.          (eval
22.            (read (strcat
23.                    "(defun " nom_cmd "(/ app)"
24.                      "(if (setq app(fdvbfile " qapp "))"
25.                        "(progn(vla-runmacro (vlax-get-acad-object) (strcat app "!" cmd ""))"
26.                        strcmd ")"
27.                        "(nodvbfile " qapp "))"
28.                    "(princ ))"
29.        )))))
30.     cmdliste
31.   )
32.   (princ)
33. )
34. (defun fdvbfile (app)
35.   (if (not (findfile app))
36.     (if (not (findfile (strcat app ".dvb"))) nil  (strcat app ".dvb")) app)
37. )
38. (defun nodvbfile (filename)
39.   (princ (strcat "\n文件 " filename "(.dvb) 在搜索路径文件夹中未找到。" ))
40.   (princ "\n请检查支持文件的安装，然后重试。")
41.   (princ)
42. )

;;自动加载VBA程序的函数   (vl-load-com) (defun AutoVBALoad (app cmdliste stat / qapp strcmd)   (setq qapp (strcat """ app """))   (mapcar     '(lambda (cmd / nom_cmd dot nodotcmd)        (progn          (setq dot (vl-string-search "." cmd))          (if dot            (setq nodotcmd (substr cmd (+ dot 2)))            (setq nodotcmd cmd)          )          (setq nom_cmd (strcat "C:" nodotcmd))          (if (member stat '(0 1 2 3 4 5 6 7))            (setq strcmd                  (strcat"(vlax-add-cmd "" nodotcmd "" \'"                         nom_cmd """ nodotcmd """ (itoa stat) " )"))            (setq strcmd "")          )          (eval            (read (strcat                    "(defun " nom_cmd "(/ app)"                      "(if (setq app(fdvbfile " qapp "))"                        "(progn(vla-runmacro (vlax-get-acad-object) (strcat app "!" cmd ""))"                        strcmd ")"                        "(nodvbfile " qapp "))"                    "(princ ))"        )))))     cmdliste   )   (princ) ) (defun fdvbfile (app)   (if (not (findfile app))     (if (not (findfile (strcat app ".dvb"))) nil  (strcat app ".dvb")) app) ) (defun nodvbfile (filename)   (princ (strcat "\n文件 " filename "(.dvb) 在搜索路径文件夹中未找到。" ))   (princ "\n请检查支持文件的安装，然后重试。")   (princ) )

现在，这个函数增加了一个参数，来让用户选择VBA命令是否生成为AutoCAD命令，或透明命令，或什么都不要，只生成执行命令。
stat参数的含义：0，做为AutoCAD内部命令。1，生成透明命令，还有2,3，4,5，6,7这几种，跟选择方式有关吧，这些的含义可查看vlax-add-cmd函数。除了以上这几种参数外，其它参数均被认为不生成AutoCAD内部命令。
上一贴的命令方法：

1. (AutoVBALoad "CC" '("cc") 3)

复制代码

再给大家举个简单的例子吧，把以下程序保存为文件ZZ.DVB文件：

2. Sub ZP()
3.     ZoomPrevious
4. End Sub
5. Sub ZA()
6.     ZoomAll
7. End Sub
8. Sub ZE()
9.     ZoomExtents
10. End Sub
11. Sub ZW()
12.     ZoomPickWindow
13. End Sub

Sub ZP()     ZoomPrevious End Sub Sub ZA()     ZoomAll End Sub Sub ZE()     ZoomExtents End Sub Sub ZW()     ZoomPickWindow End Sub

这是缩放命令的几个快捷方式，使用的是VBA方式实现，我们现在就把它做成透明命令。
(AutoVBALoad "ZZ" '("ZA" "ZP" "ZE" "ZW") 3)
这样，我们就可以在命令期间使用'za,'ze,'zp等来直接缩放窗口了。
[U]到目前为止，我们已经可以让VBA程序与LISP程序一样了。以后，我们就不用为了VBA程序难以调用，不能先选择后操作以及不能透明引用而认为VBA程序有很大的缺陷吧。[/U]

ntchjie

强烈的顶一下，好东西，要打印出来好好看看。

pckite

good!!

miaoph

太棒了

cag

什么叫AX方法？

mccad

ActiveX Automation
如取得圆的半径，用一般的方法：
(setq radius (cdr (assoc 40 (entget circle-entity))))
用ActiveX 函数，就这么简单:
(setq radius (vla-get-radius circle-object))

cag

呵，原来就是ActiveX Automation的简称啊。

tjdxtm

楼主，我用了含有透明命令的AutoVBALoad加载我的vba(在acad2002中)，在第一个drawing中调用没问题，我切换到第二个drawing中就不能调用了，提示什么lisp搭配错误，是什么原因阿？