- UID
- 6408
- 积分
- 0
- 精华
- 贡献
-
- 威望
-
- 活跃度
-
- D豆
-
- 在线时间
- 小时
- 注册时间
- 2002-6-13
- 最后登录
- 1970-1-1
|
马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。
您需要 登录 才可以下载或查看,没有账号?立即注册
×
为什么不能回帖了?不知道违反了哪个发贴规则,请明示。
按照xyp1964兄的方法,我昨天试了一晚上始终不得要领。还望各位帮一把。
这次我修改后,不知为什么菜单总加不上,支持路径倒加上了进入后,在加载应用程序内手工加载一遍就ok了。这次不知问题出在哪里。
;;; 判断是否加载本文件
(if (car (atoms-family 1 '("vl-load-com")))
(vl-load-com)
(progn
(Alert
"阿炳设计助手提示您:非常抱歉,这个程序集是为AutoCAD 2000以及更高的版本设计的,许多程序有可能在AutoCAD R14上不能正确地运行,建议您升级至2000以上版本。"
)
(exit) ; 版本不符,退出加载。
)
)
;; 首先定义初始化函数
(defun InitarbingApplication (/
GetMyApplicationPath
GetarbingPath
strParse
StrUnParse
arbing_AddSupportPath
Load_arbingMenu
arbing_placemenu
arbing_cmdecho_save
)
;;; 取得本程序的路径.
;;; 文件路径从注册表中读取,这些信息由安装程序负责写入注册表
;;; ---------------------------------------------------------------------------------
(defun GetMyApplicationPath (AppID)
(vl-registry-read
(strcat
"HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Uninstall\\"
AppID
"_is1"
)
"Inno Setup: App Path"
)
)
;; 这里取得安装后,安装的文件夹的绝对路径
;; 注意:这里的AppID为"阿炳设计助手", 稍后的安装程序制作向导设置中必须与这里保持一致
(defun GetarbingPath ()
(GetMyApplicationPath "阿炳设计助手")
)
;;; 解析字符串为表(函数来自明经通道转载)
;;; ---------------------------------------------------------------------------------
(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
;;; 添加支持文件搜索路径
;;; ---------------------------------------------------------------------------------
;;; note: 第二个参数如果为真, 插最前,否则插最后
;;;
(defun arbing_AddSupportPath (PathToAdd isFirst / supportlist)
(if (not
(vl-string-search
(strcase (strcat pathToAdd ";"))
(strcase (strcat (getenv "ACAD") ";"))
)
) ; 保证不重复添加
(progn
(setq supportlist (strparse (getenv "ACAD") ";"))
(setq supportlist
(vl-remove-if-not
'vl-file-directory-p
supportlist
)
) ; 移除不存在的文件夹
(if isFirst
(setq supportlist (cons PathToAdd supportlist))
(setq supportlist (append supportlist (list PathToAdd)))
)
(setenv "ACAD" (strUnParse supportlist ";"))
)
)
)
;;; 初始化主函数
;;; ---------------------------------------------------
;;; 添加支持路径
(arbing_AddSupportPath (GetarbingPath) nil)
(arbing_AddSupportPath (strcat (GetarbingPath) "\\ada") nil)
;; 根据不同的AutoCAD版本加载不同的菜单文件。
(defun Load_arbingMenu (/ acadver)
(setq acadver (atof (getvar "acadver")))
(cond
((and (>= acadver 15.0) (< acadver 16.0))
(command "_menuload" "arbing.mns")
)
((and (>= acadver 16.0) (<= acadver 16.1))
(command "_menuload" "arbing2004.mns")
)
((>= acadver 16.2) (command "_menuload" "arbing2006.mns"))
)
)
;; 这个函数用来插入菜单条
;; The following code "placemenu" from LUCAS(龙龙仔)
(defun arbing_placemenu (/ n)
(if (menugroup "arbing")
(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
;; 如需插入多条菜单,以反序在这里写:
;; 因只有一条下拉菜单,因此这里4,3条注释掉
;; (menucmd (strcat "p" (itoa n) "=+arbing.pop4"))
;; (menucmd (strcat "p" (itoa n) "=+arbing.pop3"))
;;(menucmd (strcat "p" (itoa n) "=+arbing.pop2"))
(menucmd (strcat "p" (itoa n) "=+arbing.pop1"))
(setq n 25)
) ;progn
) ;if
) ;while
) ;progn
) ;if
(princ)
)
;;; -----------------------------------------------------
;;; 主程序:
;;; -----------------------------------------------------
(princ "\n采撷众家之开发精髓,打造精品之设计助手!\n欢迎使用阿炳设计助手。正在加载,请稍候。")
(setq arbing_cmdecho_save (getvar "cmdecho"))
(setvar "cmdecho" 0)
;; 加载下拉菜单
(arbing_AddSupportPath (GetarbingPath) nil)
;; 如果菜单组还没有被加载,则加载之
(if (not (menugroup "arbing"))
(Load_arbingMenu)
)
;; 插到合适的位置
(arbing_placemenu)
(setvar "cmdecho" arbing_cmdecho_save)
(setq arbing_cmdecho_save nil)
(princ)
) ;_end of defun initarbingApplication
(initarbingApplication)
;; 加载主程序
;; 为节省内存,这里也可以以autoload函数形式定义
;; 有几条写几条
(load "arbing.vlx")
(princ "\n阿炳设计助手加载完毕。版本 2005.12")
(princ "\n阿炳设计助手联系邮箱:SBCSL@163.com。网址:http://arbing.wy8.net") |
|