[原创]AutoCAD二次开发程序的安装制作向导（测试），支持2006

秋枫 · 发表于 2005-4-10 01:16:00

以前我发表过一个LISP Setup用于简单的LISP程序的安装。这个程序需要设置AutoCAD菜单文件。而一些坛友对于必须要用菜单文件也很不爽。毕竟这样就不够简单了。而从AutoCAD 2006开始，菜单文件发生了变化，尤其是它的注册表结构变了。这个程序基本上废了。

近日我重新弄了一个。目标是更加简单。现在支持AutoCAD 2006，但不再支持AutoCAD R14了。希望它可以自动支持后续的AutoCAD版本。给大家测试一下先：尝鲜下载：http://quelea.w3.zccn.net/blogview.asp?logID=42 后面我有空会提供更加详细一点的信息。欢迎讨论。

spshchen · 发表于 2005-4-10 09:39:00

好东西,但是我不知道,如何增加支持文件搜索路径.

wdb · 发表于 2005-4-10 11:29:00

下载后看看

秋枫 · 发表于 2005-4-10 12:31:00

spshchen发表于2005-4-10 9:39:00好东西,但是我不知道,如何增加支持文件搜索路径.

这个我会稍后写个教程解释一下。我先贴一段例程，这段你可以参考修改后加到启动时自动加载的文件中去。

;; 取得本安装程序的路径
;; AppID即为本次安装所使用的ID
(defun GetApplicationPath (AppID)
(vl-registry-read
(strcat
"HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Uninstall\"
AppID
"_is1"
)
"Inno Setup: App Path"
)
);;;AddSupportPath
;;;添加文件夹到AutoCAD支持搜索路径中的指定位置
;;;参数
;;;文件夹路径及插入的位置(0时插入前端)
;;;示例
;;;(addSupportPath "c:\\myFolder" 2)
;;;注意
;;;位置参数为空时将文件夹添加到路径最后。位置参数为0时将文件夹添加到路径最前端。
(defun addSupportPath (dir pos / tmp c)
(setq tmp ""
c -1
)
(if (not pos)
(setq tmp (strcat (getenv "ACAD") ";" dir))
(mapcar '(lambda (x)
(setq tmp (if (= (setq c (1+ c)) pos)
(strcat tmp ";" dir ";" x)
(strcat tmp ";" x)
)
)
)
(parse (getenv "ACAD") ";")
)
)
(setenv "ACAD" tmp)
(princ)
);;;removeSupportPath
;;;从AutoCAD支持搜索路径中移去指定文件夹
;;;参数
;;;所要移去的文件夹
;;;示例
;;;(removeSupportPath "c:\myFolder")
(defun removeSupportPath (dir / tmp)
(setq tmp "")
(mapcar '(lambda (x)
(if (/= (strcase x) (strcase dir))
(setq tmp (strcat tmp x ";"))
)
)
(parse (getenv "ACAD"))
)
(setenv "ACAD" (substr tmp 1 (1- (strlen tmp))))
(princ)
);; 加载菜单样例：
(defun AddDemoMenu ()
(if (menugroup "DemoMenu") ; 菜单组名为DemoMenu, 已经加载
(progn
(command "_menuunload" "DemoMenu")
(command "_menuload" "DemoMenu.mnu")
(menucmd "p8=+DemoMenu.pop1")
(menucmd "p9=+DemoMenu.pop2")
(menucmd "p10=+DemoMenu.pop3")
(princ "\n DemoMenu 菜单载入.")
)
(progn
(command "_menuload" "DemoMenu.mnu")
(menucmd "p8=+DemoMenu.pop1") ; 插在第8个位子
(menucmd "p9=+DemoMenu.pop2") ; 插在第8个位子
(menucmd "p10=+DemoMenu.pop3") ; 插在第10个位子
(princ "\n DemoMenu 菜单载入.")
)
)
)

;; 取得本安装程序的路径
;; AppID即为本次安装所使用的ID
(defun GetApplicationPath (AppID)
   (vl-registry-read
       (strcat
           "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Uninstall\"
           AppID
           "_is1"
       )
       "Inno Setup: App Path"
   )
);;;AddSupportPath
;;;添加文件夹到AutoCAD支持搜索路径中的指定位置
;;;参数
;;;文件夹路径及插入的位置(0时插入前端)
;;;示例
;;;(addSupportPath "c:\\myFolder" 2) 
;;;注意
;;;位置参数为空时将文件夹添加到路径最后。位置参数为0时将文件夹添加到路径最前端。
(defun addSupportPath (dir pos / tmp c)
   (setq  tmp ""
  c     -1
   )
   (if (not pos)
       (setq tmp (strcat (getenv "ACAD") ";" dir))
       (mapcar '(lambda (x)
               (setq tmp (if (= (setq c (1+ c)) pos)
           (strcat tmp ";" dir ";" x)
           (strcat tmp ";" x)
       )
               )
           )
         (parse (getenv "ACAD") ";")
       )
   )
   (setenv "ACAD" tmp)
   (princ)
);;;removeSupportPath
;;;从AutoCAD支持搜索路径中移去指定文件夹
;;;参数
;;;所要移去的文件夹
;;;示例
;;;(removeSupportPath "c:\myFolder") 
(defun removeSupportPath (dir / tmp)
   (setq tmp "")
   (mapcar '(lambda (x)
           (if (/= (strcase x) (strcase dir))
               (setq tmp (strcat tmp x ";"))
           )
       )
     (parse (getenv "ACAD"))
   )
   (setenv "ACAD" (substr tmp 1 (1- (strlen tmp))))
   (princ)
);; 加载菜单样例：
(defun AddDemoMenu ()
   (if (menugroup "DemoMenu")  ; 菜单组名为DemoMenu, 已经加载
       (progn
           (command "_menuunload" "DemoMenu")
           (command "_menuload" "DemoMenu.mnu") 
           (menucmd "p8=+DemoMenu.pop1")  
           (menucmd "p9=+DemoMenu.pop2")
           (menucmd "p10=+DemoMenu.pop3")
           (princ "\n DemoMenu 菜单载入.")
       )
       (progn
           (command "_menuload" "DemoMenu.mnu")
           (menucmd "p8=+DemoMenu.pop1")  ; 插在第8个位子
           (menucmd "p9=+DemoMenu.pop2")  ; 插在第8个位子
           (menucmd "p10=+DemoMenu.pop3")  ; 插在第10个位子
           (princ "\n DemoMenu 菜单载入.")
       )
   )
)

spshchen · 发表于 2005-4-10 12:51:00

太好了,我刚需要这个东西,这样我就可以做个自己的工具集了,

wengsg · 发表于 2005-4-22 17:22:00

我安装了程序后，命令程序是可以用，但在CAD2005里看不到我的菜单，帮帮忙。我的原文件： 1、wltool2005.mnu ***MENUGROUP=WLTOOL
***POP1 [实用工具(&A)]
ID_TCCC [图层(&)]^C^Cjccc
ID_CLHWTA [地质岩性(&H)]^C^C$i=WLTOOL.KUAWEN $i=*
ID_iFM 　　 [测绘图库(&I)]^C^C$i=WLTOOL.DOOR $i=*
ID_TT 　　 [z坐标输入(&t)]^C^CTT
ID_gch 　　 [高程点输入(&t)]^C^CTT0
ID_linetopl　 [转换LINE线至LWPOLYLINE(&t)]^C^Clinetopl
ID_lwtopl　　 [转换LWPOLYLINE线至POLYLINE(&t)]^C^Clwtopl
ID_linetype 　 [定制线型(&L)]^C^C-linetype
ID_tl 　 [地质图例(&D)]^C^C$i=WLTOOL.dzht $i=* [--]
ID_MnEXDraw [总图线型]^C^C$i=WLTOOL.FSLTCHG $i=*
[绿化线型]^C^C$i=WLTOOL.TREELT $i=* 2、wltool.lsp ;;; 判断是否加载本文件
(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 GetWLTOOLPath ()
(GetMyApplicationPath "WLTOOL for AutoCAD")
) ;;; 解析字符串为表（函数来自明经通道转载）
;;; ---------------------------------------------------------------------------------
(defun strParse (Str Delimiter / SearchStr StringLen return n char)
(setq SearchStr Str)
(setq StringLen (strlen SearchStr))
(setq return '())
(while (&gt 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 ";"))
) ;;; 根据不同的AutoCAD版本加载不同的菜单文件：
(defun Load_WLTOOLMenu (/ acadver)
(setq acadver (atof (getvar "acadver")))
(cond
((and
(&gt = acadver 15.0)
(&lt acadver 16.0)
)
(command "_menuload" "WLTOOL.mnu")
)
((and
(&gt = acadver 16.0)
(&lt= acadver 16.1)
)
(command "_menuload" "WLTOOL2005.mnu")
;| ((>= acadver 16.2) (command "_menuload" "QTools2006.mnu"))
)
)
|;
;;; The following code "placemenu" written by LUCAS
;;; 插入菜单条 Placemenu由LUCAS编写
;;; ---------------------------------------------------------------------------------
(defun WLTOOL_PlaceMenu (/ n)
(if (menugroup "WLTOOL")
(progn
(setq n 1)
(while
(&lt n 24)
(if (menucmd (strcat "P" (itoa n) ".1=?"))
(setq n (+ n 1))
(progn
(if (&gt n 3)
(setq n (- n 2))
(setq n 3) ) ;if
(menucmd (strcat "p" (itoa n) "=+WLTOOL.pop3")
)
(menucmd (strcat "p" (itoa n) "=+WLTOOL.pop2")
)
(menucmd (strcat "p" (itoa n) "=+WLTOOL.pop1")
)
(setq n 25)
) ;progn
) ;if
)
) ;while
) ;progn
) ;if
(princ)
) ;;; 初始化主函数
;;; ---------------------------------------------------
(defun
Init_WLTOOL
()
;; 添加支持路径
(QF_AddSupportPath (GetWLTOOLPath) nil)
(QF_AddSupportPath
(strcat (GetWLTOOLPath) "\\DOOR")
nil
)
(QF_AddSupportPath
(strcat (GetWLTOOLPath) "\\FONTS")
nil
)
(QF_AddSupportPath
(strcat (GetWLTOOLPath) "\\LINE")
nil
)
(QF_AddSupportPath
(strcat (GetWLTOOLPath) "\\LISP")
nil
)
(QF_AddSupportPath
(strcat (GetWLTOOLPath) "\\PAT")
nil
)
(QF_AddSupportPath
(strcat (GetWLTOOLPath) "\\SLB")
nil
) ;; 如果菜单组还没有被加载，则加载之
(if (not (menugroup "WLTOOL"))
(Load_WLTOOLMenu)
) ;; 安排菜单条的位置
(WLTOOL_PlaceMenu) (princ)
)
)
;;; 以上函数部分定义完毕 ;;; -----------------------------------------------------
;;; 主程序：
;;; -----------------------------------------------------
(princ "\n加载WLTOOL工具集……") (setq WLTOOL_cmdecho_save (getvar "cmdecho"))
(setvar "cmdecho" 0) ;;; 执行初始化
(Init_WLTOOL) (setvar "cmdecho" WLTOOL_cmdecho_save)
(setq WLTOOL_cmdecho_save nil) (princ "\nWLTOOL工具集加载完毕。版本 2005.4")
(princ) ;; autoload
(autoload "wltool" '("JC" "JCCC" "WL" "LWTOPL2"))
;; ……下略
)

onej · 发表于 2005-4-22 18:33:00

请问一个问题:
在ISetup制作安装向导的时候,如何在开始安装之前判别系统有没有装AUTOCAD,就象秋枫以前的那个安装向导一样,我知道是读注册表,但具体的实现还是不会,能指点指点吗?

didini · 发表于 2005-4-22 19:16:00

多谢！不过需要好好研究了！

秋枫 · 发表于 2005-4-22 20:46:00

本帖最后由作者于 2005-4-23 9:58:25 编辑

wengsg发表于2005-4-22 17:22:00(menucmd (strcat \"p\" (itoa n) \"=+WLTOOL.pop3\") ) (menucmd (strcat \"p\" (itoa n) \"=+WLTOOL.pop2\") ) (menucmd (strcat \"p\" (itoa n) \"=+WLTOOL.pop1\") ) ...

这里你只有一条菜单，因此， (menucmd (strcat "p" (itoa n) "=+WLTOOL.pop3")
)
(menucmd (strcat "p" (itoa n) "=+WLTOOL.pop2")
) 这两句是多余的，而且我认为会导致LSP出错，从这里中断执行。因此后面的代码没有执行。你可以在Vlisp调试器中逐句单步执行测试。

另，你的贴文中的&gt符号之类的不知你原文是否存在……这个也是不对头的。我前面贴的源代码中有这些东东是因为明经通道的论坛的原因，自动转化了一些符号。我现在已经改过来了。请重新拷贝。这个样例LISP程序只是我提供的一个解决方案。你完全可以不必照搬。如果其中有什么错误或不妥我相信各高手也会有自己的看法。因为它是纯lisp程序，我相信大家自己搞得定的。在晓东cad空间论坛上我也贴了这个教程，有些网友对这段代码作了改进，我觉得也挺不错的。

秋枫 · 发表于 2005-4-22 21:08:00

onej发表于2005-4-22 18:33:00请问一个问题:在ISetup制作安装向导的时候,如何在开始安装之前判别系统有没有装AUTOCAD,就象秋枫以前的那个安装向导一样,我知道是读注册表,但具体的实现还是...

如果ISetup是指Inno Setup的话，在Code段写下： const
AutoCADKey = 'Software\Autodesk\AutoCAD'; function AutoCADInstalled: boolean;
begin
Result:=RegKeyExists(HKLM, AutoCADKey);
end;
function InitializeSetup(): Boolean;
var
begin
Result := AutoCADInstalled;
end;

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