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

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

以前我发表过一个LISP Setup用于简单的LISP程序的安装。这个程序需要设置菜单文件。而一些坛友对于必须要用菜单文件也很不爽。毕竟这样就不够简单了。而从AutoCAD 2006开始，菜单文件发生了变化，尤其是它的注册表结构变了。这个程序基本上废了。
近日我重新弄了一个。目标是更加简单。现在支持AutoCAD 2006，但不再支持AutoCAD R14了。希望它可以自动支持后续的AutoCAD版本。给大家测试一下先：
尝鲜下载：
后面我有空会提供更加详细一点的信息。欢迎讨论。

本帖以下内容被隐藏保护；需要你回复后，才能看到！

游客，如果您要查看本帖隐藏内容请回复

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

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

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

下载后看看

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

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

copy


;; 取得本安装程序的路径
;; 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

这里你只有一条菜单，因此， (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

如果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;

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

发表回复

精选推荐