找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 1497|回复: 3

[每日一码] 自定义快捷菜单

[复制链接]

已领礼包: 149个

财富等级: 日进斗金

发表于 2015-2-4 19:11:50 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

您需要 登录 才可以下载或查看,没有账号?立即注册

×
  1. (vl-load-com)
  2. (defun vk_ShortcutMenu
  3.        (ItemsList / MenuGroupsObj MenuObj Input AddItems MenuName *error*)
  4.   (defun AddItems (MenuObj ItemsList)
  5.     (if  ItemsList
  6.       (if (atom (car ItemsList))
  7.   (if (= (car ItemsList) "")
  8.     (progn (vla-AddSeparator MenuObj 0) (AddItems MenuObj (cdr ItemsList)))
  9.     (progn (vla-AddMenuItem MenuObj 0 (car ItemsList) " ")
  10.      (cons (car ItemsList) (AddItems MenuObj (cdr ItemsList)))
  11.     )
  12.   )
  13.   (append  (AddItems (vla-AddSubMenu MenuObj 0 (caar ItemsList))
  14.         (reverse (cdar ItemsList))
  15.     )
  16.     (AddItems MenuObj (cdr ItemsList))
  17.   )
  18.       )
  19.     )
  20.   )
  21.   (setq MenuName "vk_Shortcut")
  22.   (if (not (vl-catch-all-error-p
  23.        (vl-catch-all-apply (function (lambda ()
  24.                (setq MenuGroupsObj (vla-get-MenuGroups (vlax-get-acad-object))
  25.                MenuObj   (vla-Item
  26.                    (vla-get-Menus
  27.                      (if (menugroup MenuName)
  28.                        (vla-Item MenuGroupsObj MenuName)
  29.                        (if (or (findfile (strcat MenuName ".mns"))
  30.                          (and (setq File (open (strcat (vl-filename-directory
  31.                                  (findfile "ACAD.mns")
  32.                                )
  33.                                "\\"
  34.                                MenuName
  35.                                ".mns"
  36.                              )
  37.                              "w"
  38.                              )
  39.                         )
  40.                         (write-line  (strcat  "***MENUGROUP="
  41.                           MenuName
  42.                           "\n***POP0\n**"
  43.                           MenuName
  44.                           "\n\t[Shortcut]"
  45.                         )
  46.                         File
  47.                         )
  48.                         (not (close File))
  49.                          )
  50.                      )
  51.                    (vla-Load MenuGroupsObj MenuName)
  52.                        )
  53.                      )
  54.                    )
  55.                    "Shortcut"
  56.                  )
  57.                )
  58.              )
  59.          )
  60.        )
  61.      )
  62.       )
  63.     (progn (menucmd (strcat "P0=" MenuName "." MenuName))
  64.      (vlax-map-Collection MenuObj 'vla-Delete)
  65.      (setq ItemsList (AddItems MenuObj (reverse ItemsList)))
  66.      (menucmd "P0=*")
  67.      (if (or (menucmd "P0=POP0") (= (car (setq Input (grread))) 11))
  68.        (nth (- (cadr Input) 500) (reverse ItemsList))
  69.      )
  70.     )
  71.   )
  72. )
  73. ;;;(vk_ShortcutMenu (list "Test1" "" (list "Test2" "Test21" "Test22" "" (list "Test23" "Test231" "Test232" "Test233")) "Test3" "" "Test4"))

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
发表于 2020-7-26 14:52:59 | 显示全部楼层
谢谢版主分享
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 1094个

财富等级: 财源广进

发表于 2021-4-22 00:15:10 | 显示全部楼层
感谢楼主分享自定义快捷菜单
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2021-4-24 10:58:40 | 显示全部楼层
感谢楼主分
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-11-15 10:54 , Processed in 0.323264 second(s), 34 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表