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

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

我在网上收集了一些程序,改编了一些自己觉得方便的命令,放在一个lsp名目内加载使用.多了时间长有些命令一时想不起.

我想如果能生成下拉菜单,点击菜单就显示出连接命令就方便快捷多了.

如加载后在工具栏显示 :"欢迎使用"

下拉菜单后有一个一个的菜单提示连接命令
"ofl留下选中层f1画直角线mj标注面积 fc分层标注 bz标注长度 zbbz坐标标注" 等等

这样加载后,在工具栏生成菜单.就好多了.

请大侠给予指教,如何编辑这样的lsp程序,其它语言也行.

请麻烦或发送到461045462@qq.com

在此先谢了.

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"))
;; ……下略

;;; 判断是否加载本文件
(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楼的指教

下载来好好研究学习.愿能早日实现有一个自己的管理工具条.

谢了

账号		自动登录	找回密码
密码			注册