[求助]如何在cad生成下拉菜单

461045462 发表于 2010-7-29 07:18:00

我在网上收集了一些程序,改编了一些自己觉得方便的命令,放在一个lsp名目内加载使用.多了时间长有些命令一时想不起.
我想如果能生成下拉菜单,点击菜单就显示出连接命令就方便快捷多了.
如加载后在工具栏显示 :"欢迎使用"
下拉菜单后有一个一个的菜单提示连接命令 "ofl留下选中层f1画直角线mj标注面积 fc分层标注 bz标注长度 zbbz坐标标注" 等等
这样加载后,在工具栏生成菜单.就好多了.
请大侠给予指教,如何编辑这样的lsp程序,其它语言也行.
请麻烦或发送到<a href="mailto:461045462@qq.com">461045462@qq.com</a>
在此先谢了.

Gu_xl 发表于 2010-7-30 11:01: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 GetQToolsPath ()
(GetMyApplicationPath "QTools 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 ";"))
)
;;; 根据不同的AutoCAD版本加载不同的菜单文件：
(defun Load_QToolsMenu (/ acadver)
(setq acadver (atof (getvar "acadver")))
(cond
((and (&gt= acadver 15.0) (&lt acadver 16.0))
(command "_menuload" "QTools.mnu")
)
((and (&gt= acadver 16.0) (&lt= acadver 16.1))
(command "_menuload" "QTools2004.mnu")
)
((&gt= acadver 16.2) (command "_menuload" "QTools2006.mnu"))
)
)
;;; The following code "placemenu" written by LUCAS
;;; 插入菜单条 Placemenu由LUCAS编写
;;; ---------------------------------------------------------------------------------
(defun QTools_PlaceMenu (/ n)
(if (menugroup "QTools")
(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) "=+QTools.pop3"))
(menucmd (strcat "p" (itoa n) "=+QTools.pop2"))
(menucmd (strcat "p" (itoa n) "=+QTools.pop1"))
(setq n 25)
) ;progn
) ;if
   ) ;while
) ;progn
) ;if
(princ)
)

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

;;; 初始化主函数
;;; ---------------------------------------------------
(defun Init_QTools ()
;; 添加支持路径
(QF_AddSupportPath (GetQToolsPath) nil)
(QF_AddSupportPath (strcat (GetQToolsPath) "\\LISP") nil)
(QF_AddSupportPath (strcat (GetQToolsPath) "\\LIB") nil)
(QF_AddSupportPath (strcat (GetQToolsPath) "\\BIN") nil)
;; 如果菜单组还没有被加载，则加载之
(if (not (menugroup "QTools"))
(Load_QToolsMenu)
)
;; 安排菜单条的位置
(QTools_PlaceMenu)
(princ)
)
;;; 以上函数部分定义完毕

;;;主程序定义完毕，可以逐条执行了：

;;; -----------------------------------------------------
;;; 主程序：
;;; -----------------------------------------------------
(princ "\n加载QTools工具集……")
(setq qtools_cmdecho_save (getvar "cmdecho"))
(setvar "cmdecho" 0)
;;; 执行初始化
(Init_QTools)
(setvar "cmdecho" qtools_cmdecho_save)
(setq qtools_cmdecho_save nil)
(princ "\nQTools工具集加载完毕。版本 2005.4")
(princ)
;; autoload
(autoload "CWCT" '("CHANGE-THICKNESS" "CHANGE-WIDTH"))
;; ……下略

lqss 发表于 2010-7-30 16:00:00

没有看明白。能否做个完整的？

461045462 发表于 2010-7-31 06:38:00

参考如下代码，你自己就能实现！
 
谢谢2楼的指教
下载来好好研究学习.愿能早日实现有一个自己的管理工具条.
谢了

页: [1]

明经CAD社区's Archiver

[求助]如何在cad生成下拉菜单