[分享]AutoVBALoad函数改进

lennie

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 "(AddCommandsInMDI ""
18.      nodotcmd
19.      "" \'"
20.      nom_cmd
21.      """
22.      nodotcmd
23.      """
24.      (itoa stat)
25.      " )"
26.     )
27.     )
28.     (setq strcmd "")
29.   )
30.   (eval
31.     (read
32.       (strcat
33.         "(defun "    nom_cmd
34.         "(/ app)"    "(if (setq app(fdvbfile "
35.         qapp     "))"
36.         "(progn(vla-runmacro (vlax-get-acad-object) (strcat app "!"
37.         cmd     ""))"
38.         strcmd     ")"
39.         "(nodvbfile "    qapp
40.         "))"     "(princ ))"
41.        )
42.     )
43.   )
44.        )
45.      )
46.     cmdliste
47.   )
48.   (princ)
49. )

;自动加载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 "(AddCommandsInMDI ""      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) )

其中vlax-add-cmd 改成了 AddCommandsInMDI 需要配合下面两个函数：

2. (defun AddCommandsHelper (CallingReactor CommandList / return ok)
3.   (foreach x *AddCommandsList*
4.     (if (and (member (type (eval (caddr x))) '(SUBR USUBR EXRXSUBR))
5.       (setq ok (apply 'vlax-add-cmd (cdr x)))
6. )
7.       (setq return (cons ok return))
8.     )
9.   )
10.   return
11. )
12. (defun AddCommandsInMDI (lst / old)
13.   (foreach x lst
14.     (vlax-remove-cmd (car x))
15.     (if (setq old (assoc (strcase (car x)) *AddCommandsList*))
16.       (setq *AddCommandsList*
17.       (subst (cons (strcase (car x)) x)
18.       old
19.       *AddCommandsList*
20.       )
21.       )
22.       (setq *AddCommandsList*
23.       (cons (cons (strcase (car x)) x)
24.      *AddCommandsList*
25.       )
26.       )
27.     )
28.   )
29.   (if (not InitializeAddCommandsReactor)
30.     (setq InitializeAddCommandsReactor
31.     (vlr-docmanager-reactor
32.       "InitializeAddCommands"
33.       '((:vlr-documentBecameCurrent . AddCommandsHelper))
34.     )
35.     )
36.   )
37.   (AddCommandsHelper NIL NIL)
38. )

(defun AddCommandsHelper (CallingReactor CommandList / return ok)   (foreach x *AddCommandsList*     (if (and (member (type (eval (caddr x))) '(SUBR USUBR EXRXSUBR))       (setq ok (apply 'vlax-add-cmd (cdr x))) )       (setq return (cons ok return))     )   )   return ) (defun AddCommandsInMDI (lst / old)   (foreach x lst     (vlax-remove-cmd (car x))     (if (setq old (assoc (strcase (car x)) *AddCommandsList*))       (setq *AddCommandsList*       (subst (cons (strcase (car x)) x)       old       *AddCommandsList*       )       )       (setq *AddCommandsList*       (cons (cons (strcase (car x)) x)      *AddCommandsList*       )       )     )   )   (if (not InitializeAddCommandsReactor)     (setq InitializeAddCommandsReactor     (vlr-docmanager-reactor       "InitializeAddCommands"       '((:vlr-documentBecameCurrent . AddCommandsHelper))     )     )   )   (AddCommandsHelper NIL NIL) )

这样就可以避免两个文档用一个命令调用VBA程序的错误了，这个方法是网上搜索来的。我学校里学的是VB，毕业自己看VBA的书，LISP是一窍不通，多亏网络的强大啊。这个bug老早就有人提过了，那个至顶的帖子几年了居然还没有解决方案，明经是不是没落了？