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

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

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

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

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

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

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

下载后看看

秋枫发表于 2005-4-10 12:31: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)
(setqtmp ""
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 　　 ^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;

页: [1] 2

乐筑天下's Archiver

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