[原创]AutoCAD二次开发程序的安装制作向导（测试），支持2006 - AutoLISP/Visual LISP 编程技术 - AutoCAD论坛 - 明经CAD社区 - 第2页

onej 发表于 2005-4-22 21:31:00

谢谢秋枫，可编译错误啊，

didini 发表于 2005-4-22 21:42:00

(while (&gt “这个到底是什么啊？”StringLen 0) (setq n 1) (setq char (substr SearchStr 1 1)) (while (and (/= char Delimiter) (/= char "")) (setq n (1+ n))

秋枫发表于 2005-4-23 09:41:00

onej发表于2005-4-22 21:31:00static/image/common/back.gif谢谢秋枫，可编译错误啊，17969

 笔误，不好意思。把var行去掉即可。

var行用于定义内部变量，这个函数没有内部变量，所以多余，去掉即可。

秋枫发表于 2005-4-23 09:42:00

didini发表于2005-4-22 21:42:00static/image/common/back.gif(while (&gt “这个到底是什么啊？”StringLen 0) (setq n 1) (setq char (substr SearchStr 1 1)) ...

 是明经通道论坛自动转化了大于符号（尖括号）。现已修正。请重新拷贝。

wengsg 发表于 2005-4-23 10:40:00

还是没用!

程序如下:

;;; 判断是否加载本文件 (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 (> 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_WLTOOLMenu (/ acadver) (setq acadver (atof (getvar "acadver"))) (cond ((and (>= acadver 15.0) (< acadver 16.0)) (command "_menuload" "WLTOOL.mnu") ) ((and (>= acadver 16.0) (<= acadver 16.1)) (command "_menuload" "WLTOOL2004.mnu") ) ((>= acadver 16.2) (command "_menuload" "WLTOOL2006.mnu")) ) )

;;; The following code "placemenu" written by LUCAS ;;; 插入菜单条 Placemenu由LUCAS编写 ;;; --------------------------------------------------------------------------------- (defun WLTOOL_PlaceMenu (/ n) (if (menugroup "WLTOOL") (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) "=+WLTOOL.pop1")) (setq n 25) ) ;progn ) ;if ) ;while ) ;progn ) ;if (princ) )

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

 ;;; 初始化主函数 ;;; --------------------------------------------------- (defun Init_WLTOOL () ;; 添加支持路径 (QF_AddSupportPath (GetWLTOOLPath) nil) (QF_AddSupportPath (strcat (GetWLTOOLPath) "<A href="file://DOOR/" target="_blank" >\\DOOR</A>") nil) (QF_AddSupportPath (strcat (GetWLTOOLPath) "<A href="file://FONTS/" target="_blank" >\\FONTS</A>") nil) (QF_AddSupportPath (strcat (GetWLTOOLPath) "<A href="file://LINE/" target="_blank" >\\LINE</A>") nil) (QF_AddSupportPath (strcat (GetWLTOOLPath) "<A href="file://LISP/" target="_blank" >\\LISP</A>") nil) (QF_AddSupportPath (strcat (GetWLTOOLPath) "<A href="file://PAT/" target="_blank" >\\PAT</A>") nil) (QF_AddSupportPath (strcat (GetWLTOOLPath) "<A href="file://SLB/" target="_blank" >\\SLB</A>") 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 "CWCT" '("CHANGE-THICKNESS" "CHANGE-WIDTH")) ;; ……下略

秋枫发表于 2005-4-23 11:17:00

朋友，你这个是纯LISP问题啊，你可以用VLISP设断点调试看看什么地方错了呀。

我猜一下：
(defun GetWLTOOLPath () (GetMyApplicationPath "WLTOOL for AutoCAD") )
这个的返回值对不对？“WLTOOL for AutoCAD”是不是与安装向导中的设置一致？

wengsg 发表于 2005-4-23 11:45:00

是这个"这个的返回值对不对？“WLTOOL for AutoCAD”是不是与安装向导中的设置一致？"原因.谢谢!

但我的菜单还是无法自动加载.

wengsg 发表于 2005-4-23 16:35:00

谢谢楼主,我的问题已解决!

didini 发表于 2005-4-23 20:43:00

经过一天的努力终于解决了！

但是有个问题，在制作setup文件的时候，需要制作一个自动加载的lisp文件，或者其它的文件，在这个文件中实现添加支持路径和菜单文件，当安装上setup以后，第一次打开cad，就会发现，在新添加路径中的acaddoc.lsp，并没有加载，但在以后就不会出现这样的情况了！

这种情况能避免吗？

秋枫发表于 2005-4-23 23:47:00

既然提供了自动加载文件，就没有必要使用acaddoc.lsp. 因为这个自动加载文件每次都会加载的。

因为这个文件很可能在其它支持路径中也有。有可能是用户自己写的，这样会导致冲突。

这种情况无法避免。你如果要加载的话，你可以在你的LSP中添加支持路径后，自己在LISP程序中加载，

例：

(addsupportpath "..XXXX")

(if (findfile "acaddoc.lsp") (load "acaddoc.lsp"))

(add supportpath ".....")

...

页: 1 [2] 3

明经CAD社区's Archiver