[原创]AutoLISP程序的安装制作教程（二）

秋枫 · 发表于 2005-4-11 21:27

接昨天的教程。今天来谈谈一些高级的话题，这些主要涉及到AutoLISP或Visual LISP的编程问题了。即如何解决向AutoCAD添加支持路径，添加菜单了。我只能说我提供一种解决方法，一种解决思路。其实这个与我做的这个安装程序制作向导本身的关系不是很大了。使用LISP方式解决的好处是：您可以最大限度地控制你的程序，按照你本人的意愿运行。
这里以我写的一个稍复杂一点的工具箱（QTools for AutoCAD）作为例子，在这个例子中，我需要添加AutoCAD支持路径，需要在启动时添加工具箱用的菜单条。
准备好文件夹，如图所示：

在这个文件夹中，可以看到有三个菜单文件，对应不同的AutoCAD版本。另有一个需要AutoCAD启动时加载的LISP程序：LoadQTools.lsp
好了，先常规设置，基本的设置我就不详述了，可以参见[教程（一）]。我们这里设置AppID为QTools for AutoCAD。如图：

指定程序文件夹与启动时要加载的文件

我们主要的工作都是在LoadQTools.lsp这个LISP程序中完成的。当然，你也可以选择ARX，VBA。它们都有能力完成这个LISP程序完成的工作。具体如何着手写你完全可以发挥你的创造性。我这里提供一个LISP的解决方案。就LISP这种方式来说，也有很多不同的解决方案，这里的思路仅供参考。
我们来分析一下LoadQTools.lsp的代码。
首先，在这个程序判断是不是AutoCAD 2000以上的版本，如果是R14，拒绝加载，退出。

;;; 判断是否加载本文件
(if (car (atoms-family 1 '("vl-load-com")))
(vl-load-com)
;;else
(progn
(Alert
"这个程序集是为AutoCAD 2000以及更高的版本设计的，许多程序有可能在没有Visual Lisp for R14支持的AutoCAD R14上不能正确地运行。"
)
(exit) ; 版本不符，退出加载。
)
)

第二步，定义一些设置菜单与支持路径要用的基本函数：

;;; 以下定义文件中用到的函数
;;;----------------------------------------------------------------------------------;;; 取得本程序的路径
;;; ---------------------------------------------------------------------------------
(defun GetMyApplicationPath (AppID)
(vl-registry-read
(strcat
"HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Uninstall\"
AppID
"_is1"
)
"Inno Setup: App Path"
)
)(defun GetQToolsPath ()
(GetMyApplicationPath "QTools for AutoCAD")
);;; 解析字符串为表（函数来自明经通道转载）
;;; ---------------------------------------------------------------------------------
(defun strParse (Str Delimiter / SearchStr StringLen return n char)
(setq SearchStr Str)
(setq StringLen (strlen SearchStr))
(setq return '())
(while (> StringLen 0)
(setq n 1)
(setq char (substr SearchStr 1 1))
(while (and (/= char Delimiter) (/= char ""))
(setq n (1+ n))
(setq char (substr SearchStr n 1))
) ;_ end of while
(setq return (cons (substr SearchStr 1 (1- n)) return))
(setq SearchStr (substr SearchStr (1+ n) StringLen))
(setq StringLen (strlen SearchStr))
) ;_ end of while
(reverse return)
) ;_ end of defun;;; 反解析表为字符串（函数来自明经通道转载）
;;; ---------------------------------------------------------------------------------
(defun StrUnParse (Lst Delimiter / return)
(setq return "")
(foreach str Lst
(setq return (strcat return Delimiter str))
) ;_ end of foreach
(substr return 2)
) ;_ end of defun;;; 移除支持文件搜索路径
;;; ---------------------------------------------------------------------------------
(defun QF_RemoveSupportPath (PathToRemove / supportlist)
(setq supportlist (strparse (getenv "ACAD") ";"))
(setq supportlist (vl-remove "" supportlist))
(setq supportlist
(vl-remove-if
'(lambda (x) (= (strcase x) (strcase PathToRemove)))
supportlist
)
)
(setenv "ACAD" (strUnParse supportlist ";"))
);;; 添加支持文件搜索路径
;;; ---------------------------------------------------------------------------------
;;; note: 第二个参数如果为真, 插最前，否则插最后
;;;
(defun QF_AddSupportPath (PathToAdd isFirst / supportlist)
(QF_RemoveSupportPath PathToAdd)
(setq supportlist (strparse (getenv "ACAD") ";"))
(setq supportlist (vl-remove "" supportlist))
(if isFirst
(setq supportlist (cons PathToAdd supportlist))
(setq supportlist (append supportlist (list PathToAdd)))
)
(setenv "ACAD" (strUnParse supportlist ";"))
)
(defun Load_QToolsMenu (/ acadver)
(setq acadver (atof (getvar "acadver")))
(cond
((and (>= acadver 15.0) (< acadver 16.0))
(command "_menuload" "QTools.mnu")
)
((and (>= acadver 16.0) (<= acadver 16.1))
(command "_menuload" "QTools2004.mnu")
)
((>= acadver 16.2) (command "_menuload" "QTools2006.mnu"))
)
);;; The following code "placemenu" written by LUCAS
;;; 插入菜单条 Placemenu由LUCAS编写
;;; ---------------------------------------------------------------------------------
(defun QTools_PlaceMenu (/ n)
(if (menugroup "QTools")
(progn
(setq n 1)
(while (< n 24)
(if (menucmd (strcat "P" (itoa n) ".1=?"))
(setq n (+ n 1))
(progn
(if (> n 3)
(setq n (- n 2))
(setq n 3)
) ;if
(menucmd (strcat "p" (itoa n) "=+QTools.pop3"))
(menucmd (strcat "p" (itoa n) "=+QTools.pop2"))
(menucmd (strcat "p" (itoa n) "=+QTools.pop1"))
(setq n 25)
) ;progn
) ;if
) ;while
) ;progn
) ;if
(princ)
)

;;; 以下定义文件中用到的函数 
;;;----------------------------------------------------------------------------------;;; 取得本程序的路径 
;;; --------------------------------------------------------------------------------- 
(defun GetMyApplicationPath (AppID) 
   (vl-registry-read 
       (strcat 
           "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Uninstall\" 
           AppID 
           "_is1" 
       ) 
       "Inno Setup: App Path" 
   ) 
)(defun GetQToolsPath () 
   (GetMyApplicationPath "QTools for AutoCAD") 
);;; 解析字符串为表（函数来自明经通道转载） 
;;; --------------------------------------------------------------------------------- 
(defun strParse (Str Delimiter / SearchStr StringLen return n char) 
   (setq SearchStr Str) 
   (setq StringLen (strlen SearchStr)) 
   (setq return '()) 
   (while (> StringLen 0) 
       (setq n 1) 
       (setq char (substr SearchStr 1 1)) 
       (while (and (/= char Delimiter) (/= char "")) 
           (setq n (1+ n)) 
           (setq char (substr SearchStr n 1)) 
       ) ;_ end of while 
       (setq return (cons (substr SearchStr 1 (1- n)) return)) 
       (setq SearchStr (substr SearchStr (1+ n) StringLen)) 
       (setq StringLen (strlen SearchStr)) 
   ) ;_ end of while 
   (reverse return) 
) ;_ end of defun;;; 反解析表为字符串（函数来自明经通道转载） 
;;; --------------------------------------------------------------------------------- 
(defun StrUnParse (Lst Delimiter / return) 
   (setq return "") 
   (foreach str Lst 
       (setq return (strcat return Delimiter str)) 
   ) ;_ end of foreach 
   (substr return 2) 
) ;_ end of defun;;; 移除支持文件搜索路径 
;;; --------------------------------------------------------------------------------- 
(defun QF_RemoveSupportPath (PathToRemove / supportlist) 
   (setq supportlist (strparse (getenv "ACAD") ";")) 
   (setq supportlist (vl-remove "" supportlist)) 
   (setq supportlist 
                 (vl-remove-if 
                     '(lambda (x) (= (strcase x) (strcase PathToRemove))) 
                     supportlist 
                 ) 
   ) 
   (setenv "ACAD" (strUnParse supportlist ";")) 
);;; 添加支持文件搜索路径 
;;; --------------------------------------------------------------------------------- 
;;; note:   第二个参数如果为真, 插最前，否则插最后 
;;;                
(defun QF_AddSupportPath (PathToAdd isFirst / supportlist) 
   (QF_RemoveSupportPath PathToAdd) 
   (setq supportlist (strparse (getenv "ACAD") ";")) 
   (setq supportlist (vl-remove "" supportlist)) 
   (if isFirst 
       (setq supportlist (cons PathToAdd supportlist)) 
       (setq supportlist (append supportlist (list PathToAdd))) 
   ) 
   (setenv "ACAD" (strUnParse supportlist ";")) 
) 
(defun Load_QToolsMenu (/ acadver) 
   (setq acadver (atof (getvar "acadver"))) 
   (cond 
       ((and (>= acadver 15.0) (< acadver 16.0)) 
         (command "_menuload" "QTools.mnu") 
       ) 
       ((and (>= acadver 16.0) (<= acadver 16.1)) 
         (command "_menuload" "QTools2004.mnu") 
       ) 
       ((>= acadver 16.2) (command "_menuload" "QTools2006.mnu")) 
   ) 
);;; The following code "placemenu" written by LUCAS 
;;; 插入菜单条 Placemenu由LUCAS编写 
;;; --------------------------------------------------------------------------------- 
(defun QTools_PlaceMenu (/ n) 
   (if (menugroup "QTools") 
       (progn 
           (setq n 1) 
           (while (< n 24) 
               (if (menucmd (strcat "P" (itoa n) ".1=?")) 
                   (setq n (+ n 1)) 
                   (progn 
                       (if (> n 3) 
                           (setq n (- n 2)) 
                           (setq n 3) 
                       )                                                     ;if 
                       (menucmd (strcat "p" (itoa n) "=+QTools.pop3")) 
                       (menucmd (strcat "p" (itoa n) "=+QTools.pop2")) 
                       (menucmd (strcat "p" (itoa n) "=+QTools.pop1")) 
                       (setq n 25) 
                   )                                                         ;progn 
               )                                                             ;if 
           )                                                                 ;while 
       )                                                                     ;progn 
   )                                                                         ;if 
   (princ) 
)

好了，下面可以开始设计初始化工具箱的主程序了：

;;; 初始化主函数
;;; ---------------------------------------------------
(defun Init_QTools ()
;; 添加支持路径
(QF_AddSupportPath (GetQToolsPath) nil)
(QF_AddSupportPath (strcat (GetQToolsPath) "\\LISP") nil)
(QF_AddSupportPath (strcat (GetQToolsPath) "\\LIB") nil)
(QF_AddSupportPath (strcat (GetQToolsPath) "\\BIN") nil) ;; 如果菜单组还没有被加载，则加载之
(if (not (menugroup "QTools"))
(Load_QToolsMenu)
) ;; 安排菜单条的位置
(QTools_PlaceMenu) (princ)
)
;;; 以上函数部分定义完毕

主程序定义完毕，可以逐条执行了：

;;; -----------------------------------------------------
;;; 主程序：
;;; -----------------------------------------------------
(princ "\n加载QTools工具集……")(setq qtools_cmdecho_save (getvar "cmdecho"))
(setvar "cmdecho" 0)(Init_QTools)
(setvar "cmdecho" qtools_cmdecho_save)
(setq qtools_cmdecho_save nil)(princ "\nQTools工具集加载完毕。版本 2005.4")
(princ);; autoload
(autoload "CWCT" '("CHANGE-THICKNESS" "CHANGE-WIDTH"))
;; ……下略

上面的代码最后，开始定义按需加载的LISP程序了。关于Autoload函数我就不多解释了，可以参考AutoCAD的相关文档。Autoload这部分也可以定义在相应菜单文件的MNL文件中。这个MNL文件会在菜单加载时自动加载。在AutoCAD2006中，菜单文件的格式发生了一点变化，它仍然支持MNU, MNS, MNC文件，但它的文档中称这几个格式在未来的AutoCAD版本中不再支持。新的菜单格式为CUI文件。上述代码中使用的仍然是MNU文件，在AutoCAD 2006中是可以运行的，但在将来的AutoCAD版本中，需要作一些改变。至此，这个加载过程完毕。通过安装制作向导的包装，完全可以生成一个看上去比较专业的安装程序了。(全文完)相关链接：
  ● AutoLISP程序的安装制教程（一）
  ● AutoCAD二次开发程序的安装制作向导
  ● Inno Setup
  ● 7-zip

zjh2785 · 发表于 2017-10-12 19:44

这个碰到个BUG，

(defun StrParse (Str Delimiter / SearchStr StringLen return n char)
(setq SearchStr Str)
(setq StringLen (strlen SearchStr))
(setq return '())
(while (> StringLen 0)
(setq n 1)
(setq char (substr SearchStr 1 1))
(while (and (/= char Delimiter) (/= char ""))
(setq n (1+ n))
(setq char (substr SearchStr n 1))
)
(setq return (cons (substr SearchStr 1 (1- n)) return))
(setq SearchStr (substr SearchStr (1+ n) StringLen))
(setq StringLen (strlen SearchStr))
)
(reverse return)
)

这个函数如果碰到中文目录，就无法正常去除，因为每次取一个字节，二中文占有2个字节，

fayadetudou · 发表于 2023-10-25 11:18

这个程序就是用这个东东做的安装程序： http://quelea.w3.zccn.net/blogview.asp?logID=41 你可以试一下。

鑫诚科技 · 发表于 2023-9-8 21:34

向大神致敬~~

龙龙仔 · 发表于 2005-4-12 08:16

本帖最后由作者于 2005-4-12 8:58:41 编辑

有繁体(介面)版吗?

秋枫 · 发表于 2005-4-12 19:47

[此贴子已经被作者于2...

这个生成向导目前还没有，换成繁体界面还要点时间。不过，用它生成的安装程序有繁体版界面。目前生成的安装程序有三个界面，自动根据不同的操作系统选择简体中文，繁体中文，英文。

以下是引用龙龙仔在2005-4-12 8:16:20的发言：
有繁体(介面)版吗?

孤独客 · 发表于 2005-4-12 22:19

这么做成的安装程序安装以后把安装形成的所有的文件拷贝到别的计算机上能否好使?

秋枫 · 发表于 2005-4-12 22:54

孤独客发表于2005-4-12 22:19:00这么做成的安装程序安装以后把安装形成的所有的文件拷贝到别的计算机上能否好使?

这个程序就是用这个东东做的安装程序： http://quelea.w3.zccn.net/blogview.asp?logID=41 你可以试一下。

龙龙仔 · 发表于 2005-4-13 08:40

繁体(介面)版! ok! good! 谢谢!

Gu_xl · 发表于 2005-4-14 12:06

这东西太好了！十分感谢！

spring · 发表于 2005-4-15 21:49

请问秋枫你的安装程序是怎样将程序加载到启动组的,是注册表吗?

spring · 发表于 2005-4-15 22:01

还有用自动打印的怎么会少了一条边呢?

spring · 发表于 2005-4-15 22:12

注册表的我已经找到了可是每次启动的时候怎么会有错误提示,这是什么原因模型空间的批量打印程序
命令: BatchPlot 或 BPlot
命令: loaded.
DOSLib Version 6.1.2 (Mar 18 2003)
Copyright ?1992-2003, Robert McNeel & Associates
; 错误: 已加载该 LISP 应用程序 BatchPlot

账号		自动登录	找回密码
密码			注册

[原创]AutoLISP程序的安装制作教程（二）

本帖子中包含更多资源

评分

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源