鼠标右键菜单无级限_CAD中文技术交流网

鼠标右键菜单无级限

本帖最后由 dcl1214 于 2025-10-7 13:01 编辑

(defun $chuang-jian-you-jian-cai-dan$
(data-all xsng? lst
/ $addmenuitem$
$get-menu-name$ a
a-car a-cdr b
c count d
d2 data-all-tmp
item label labels-all
labels-loc mainItem menu
menu-obj menu-obj-up
old pos submenu
tag typ typ-old
yj yj-mr
)
;右键菜单
;data-all 所有的右键菜单
;xsng? 显示data-all中哪一个？
(defun $get-menu-name$ (a labs / b lab)
(while (setq b (car a))
(cond
((= (type (car b)) 'str)
(setq lab (car b))
(setq labs (cons lab labs))
)
((= (type (car b)) 'list)
(if (setq lab (cdr (assoc "label" b)))
(setq labs (cons lab labs))
)
)
)
(setq a (cdr a))
)
labs
)
(defun $addmenuitem$ (obj a / caption label macro obj-new)
(setq label (cdr (assoc "label" a)))
(setq macro (cdr (assoc "macro" a)))
(setq caption (cdr (assoc "caption" a)))
(setq obj-new (vl-catch-all-apply
'vla-addmenuitem
(list obj POS label macro)
)
)
(if (vl-catch-all-error-p obj-new)
(setq obj-new nil)
)
obj-new ;返回
)
(if (= (strcase (getvar 'product)) "ZWCAD")
(progn
(setq yj-mr
(vl-catch-all-apply
'vla-item
(list
(vla-get-menus
(vl-catch-all-apply
'vla-item
(list (vla-get-MenuGroups (vlax-get-acad-object))
"ZWCAD"
)
)
)
"默认模式的上下文菜单";如果希望在选中图元后再鼠标右键显示菜单可以改为"编辑模式的上下文菜单"
)
)
)
)
(progn
(setq yj-mr
(vl-catch-all-apply
'vla-item
(list
(vla-get-menus
(vl-catch-all-apply
'vla-item
(list (vla-get-MenuGroups (vlax-get-acad-object))
"ACAD"
)
)
)
"默认菜单";如果希望在选中图元后再鼠标右键显示菜单可以改为"编辑菜单"
)
)
)
)
)
(setq labels-all nil)
(setq data-all-tmp (mapcar 'cdr data-all))
(while (setq a (car data-all-tmp))
(setq labels-all ($get-menu-name$ a labels-all))
(setq data-all-tmp (cdr data-all-tmp))
) ;所有的label标识抓出来（不会玩递归，先这样写吧）
(setq labels-loc nil)
(setq d (cdr (assoc xsng? data-all))) ;需要显示的给抓出来
(setq labels-loc ($get-menu-name$ d labels-loc))
;本次需要显示的菜单labels抓出来
(setq typ-old nil)
(vlax-for item yj-mr
(setq label (vla-get-label item))
(setq tag (vla-get-tagstring item))
(setq typ (vla-get-type item))
(cond ((and (vl-position label labels-loc)
(not vlisp-compile) ;vlide界面没打开（用户状态，不是开发者模式）
)
t
)
((vl-position label labels-all)
(vl-catch-all-apply 'vla-delete (list item))
)
(t
(if
(and typ-old (= typ-old typ 1))
(vl-catch-all-apply 'vla-delete (list item))
)
)
)
(setq typ-old typ)
)
(SETQ COUNT (VLA-GET-COUNT YJ-mr))
(SETQ POS COUNT)
(setq pos 1) ;强制从第二个开始，注释这一句，可以从最后一个开始
(if (= (vla-get-type (vla-item YJ-mr pos)) 0)
(vla-AddSeparator YJ-mr (setq pos (1+ pos)))
) ;前面一个菜单不是分割线就加一个分割线
(setq menu-obj-up nil)
(while (setq a (car d))
(SETQ A-CAR (car a))
(SETQ A-CDR (cdr a))
(SETQ POS (1+ POS))
(cond
((= (type A-CAR) 'str)
(cond ((and (setq old (cdr (assoc A-CAR menu-obj-up)))
(setq SubMenu (vl-catch-all-apply
'vla-AddSubMenu
(list old 0 A-CAR)
)
)
) ;如果找到了历史的记录就在该记录下面创建一个子级菜单
t
)
((setq SubMenu (vl-catch-all-apply
'vla-AddSubMenu
(list YJ-mr pos A-CAR)
)
) ;直接创建一级菜单
t
)
)
(setq d2 nil)
(while (setq b (car a-cdr))
(cond
((= (type (car b)) 'str)
(setq d (append d (list b)))
(setq menu-obj-up (cons (cons (car b) SubMenu) menu-obj-up))
;将上级菜单对应的obj对象添加到记录里面，便于while二次查找
)
((= (type (car b)) 'list)
(setq d2 (cons b d2))
)
)
(setq a-cdr (cdr a-cdr))
) ;不会玩递归，先这样写吧
(setq d2 (reverse d2))
(while (setq c (car d2))
($addmenuitem$ SubMenu c)
(setq d2 (cdr d2))
)
;循环创建菜单
)
((= (type A-CAR) 'list)
(setq menu-obj ($addmenuitem$ yj-mr a))
)
)
(setq d (cdr d))
)
(if (= (vla-get-type (vla-item YJ-mr (setq pos (1+ pos)))) 0)
(vla-AddSeparator YJ-mr pos)
) ;后面菜单不是分割线就加一个分割线
(princ)
)
(defun $you-jian-cai-dan-test$ ()
(list
"右键菜单测试"
(list
"绘图"
(list
(cons "label" "画直线")
(cons
"macro"
"line "
)
)
(list
(cons "label" "画圆")
(cons
"macro"
"CIRCLE "
)
)
)
(list
"修改2"
(list
(cons "label" "修改颜色")
(cons
"macro"
"(vl-cmdf \"change\" (car(entsel)) \"\" \"P\" \"C\" 2 \"\") "
)
)
(list
(cons "label" "修改图层")
(cons
"macro"
"(vl-cmdf \"change\" (car(entsel)) \"\" \"P\" \"LA\" \"0\" \"\") "
)
)
(list
"修改2子级"
(list
(cons "label" "修改颜色")
(cons
"macro"
"(vl-cmdf \"change\" (car(entsel)) \"\" \"P\" \"C\" 2 \"\") "
)
)
(list
(cons "label" "修改图层")
(cons
"macro"
"(vl-cmdf \"change\" (car(entsel)) \"\" \"P\" \"LA\" \"0\" \"\") "
)
)
)
)
)
)
(SETQ DATA (LIST ($you-jian-cai-dan-test$)))
($chuang-jian-you-jian-cai-dan$ DATA "右键菜单测试" nil)

(defun $chuang-jian-you-jian-cai-dan$ 
              (data-all    xsng?       lst 
               /    $addmenuitem$ 
               $get-menu-name$       a 
               a-car    a-cdr       b 
               c    count       d 
               d2    data-all-tmp 
               item    label       labels-all 
               labels-loc mainItem   menu 
               menu-obj    menu-obj-up 
               old    pos       submenu 
               tag    typ       typ-old 
               yj    yj-mr 
              ) 
          ;右键菜单 
          ;data-all 所有的右键菜单 
          ;xsng? 显示data-all中哪一个？ 
  (defun $get-menu-name$ (a labs / b lab) 
    (while (setq b (car a)) 
      (cond 
  ((= (type (car b)) 'str) 
   (setq lab (car b)) 
   (setq labs (cons lab labs)) 
  ) 
  ((= (type (car b)) 'list) 
   (if (setq lab (cdr (assoc "label" b))) 
     (setq labs (cons lab labs)) 
   ) 
  ) 
      ) 
      (setq a (cdr a)) 
    ) 
    labs 
  ) 
  (defun $addmenuitem$ (obj a / caption label macro obj-new) 
    (setq label (cdr (assoc "label" a))) 
    (setq macro (cdr (assoc "macro" a))) 
    (setq caption (cdr (assoc "caption" a))) 
    (setq obj-new (vl-catch-all-apply 
        'vla-addmenuitem 
        (list obj POS label macro) 
      ) 
    ) 
    (if  (vl-catch-all-error-p obj-new) 
      (setq obj-new nil) 
    ) 
    obj-new        ;返回 
  ) 
  (if (= (strcase (getvar 'product)) "ZWCAD") 
    (progn 
      (setq yj-mr 
       (vl-catch-all-apply 
         'vla-item 
         (list 
     (vla-get-menus 
       (vl-catch-all-apply 
         'vla-item 
         (list (vla-get-MenuGroups (vlax-get-acad-object)) 
         "ZWCAD" 
         ) 
       ) 
     ) 
     "默认模式的上下文菜单";如果希望在选中图元后再鼠标右键显示菜单可以改为"编辑模式的上下文菜单" 
         ) 
       ) 
      ) 
    ) 
    (progn 
      (setq yj-mr 
       (vl-catch-all-apply 
         'vla-item 
         (list 
     (vla-get-menus 
       (vl-catch-all-apply 
         'vla-item 
         (list (vla-get-MenuGroups (vlax-get-acad-object)) 
         "ACAD" 
         ) 
       ) 
     ) 
     "默认菜单";如果希望在选中图元后再鼠标右键显示菜单可以改为"编辑菜单" 
         ) 
       ) 
      ) 
    ) 
  ) 
  (setq labels-all nil) 
  (setq data-all-tmp (mapcar 'cdr data-all)) 
  (while (setq a (car data-all-tmp)) 
    (setq labels-all ($get-menu-name$ a labels-all)) 
    (setq data-all-tmp (cdr data-all-tmp)) 
  )          ;所有的label标识抓出来（不会玩递归，先这样写吧） 
  (setq labels-loc nil) 
  (setq d (cdr (assoc xsng? data-all)))  ;需要显示的给抓出来   
  (setq labels-loc ($get-menu-name$ d labels-loc)) 
          ;本次需要显示的菜单labels抓出来 
  (setq typ-old nil) 
  (vlax-for item yj-mr 
    (setq label (vla-get-label item)) 
    (setq tag (vla-get-tagstring item)) 
    (setq typ (vla-get-type item)) 
    (cond ((and  (vl-position label labels-loc) 
    (not vlisp-compile)  ;vlide界面没打开（用户状态，不是开发者模式） 
     ) 
     t 
    ) 
    ((vl-position label labels-all) 
     (vl-catch-all-apply 'vla-delete (list item)) 
    ) 
    (t 
     (if 
       (and typ-old (= typ-old typ 1)) 
        (vl-catch-all-apply 'vla-delete (list item)) 
     ) 
    ) 
    ) 
    (setq typ-old typ) 
  ) 
  (SETQ COUNT (VLA-GET-COUNT YJ-mr)) 
  (SETQ POS COUNT) 
  (setq pos 1)        ;强制从第二个开始，注释这一句，可以从最后一个开始 
  (if (= (vla-get-type (vla-item YJ-mr pos)) 0) 
    (vla-AddSeparator YJ-mr (setq pos (1+ pos))) 
  )          ;前面一个菜单不是分割线就加一个分割线   
  (setq menu-obj-up nil) 
  (while (setq a (car d)) 
    (SETQ A-CAR (car a)) 
    (SETQ A-CDR (cdr a)) 
    (SETQ POS (1+ POS)) 
    (cond 
      ((= (type A-CAR) 'str) 
       (cond ((and (setq old (cdr (assoc A-CAR menu-obj-up))) 
       (setq SubMenu (vl-catch-all-apply 
           'vla-AddSubMenu 
           (list old 0 A-CAR) 
         ) 
       ) 
        )        ;如果找到了历史的记录就在该记录下面创建一个子级菜单 
        t 
       ) 
       ((setq SubMenu (vl-catch-all-apply 
            'vla-AddSubMenu 
            (list YJ-mr pos A-CAR) 
          ) 
        )        ;直接创建一级菜单 
        t 
       ) 
       ) 
       (setq d2 nil) 
       (while (setq b (car a-cdr)) 
   (cond 
     ((= (type (car b)) 'str) 
      (setq d (append d (list b))) 
      (setq menu-obj-up (cons (cons (car b) SubMenu) menu-obj-up)) 
          ;将上级菜单对应的obj对象添加到记录里面，便于while二次查找 
     ) 
     ((= (type (car b)) 'list) 
      (setq d2 (cons b d2)) 
     ) 
   ) 
   (setq a-cdr (cdr a-cdr)) 
       )        ;不会玩递归，先这样写吧 
       (setq d2 (reverse d2)) 
       (while (setq c (car d2)) 
   ($addmenuitem$ SubMenu c) 
   (setq d2 (cdr d2)) 
       ) 
          ;循环创建菜单 
      ) 
      ((= (type A-CAR) 'list) 
       (setq menu-obj ($addmenuitem$ yj-mr a)) 
      ) 
    ) 
    (setq d (cdr d)) 
  ) 
  (if (= (vla-get-type (vla-item YJ-mr (setq pos (1+ pos)))) 0) 
    (vla-AddSeparator YJ-mr pos) 
  )          ;后面菜单不是分割线就加一个分割线 
  (princ) 
) 
(defun $you-jian-cai-dan-test$ () 
  (list 
    "右键菜单测试" 
    (list 
      "绘图" 
      (list 
  (cons "label" "画直线") 
  (cons 
    "macro" 
    "line " 
  ) 
      ) 
      (list 
  (cons "label" "画圆") 
  (cons 
    "macro" 
    "CIRCLE " 
  ) 
      ) 
    ) 
    (list 
      "修改2" 
      (list 
  (cons "label" "修改颜色") 
  (cons 
    "macro" 
    "(vl-cmdf \"change\" (car(entsel)) \"\" \"P\" \"C\" 2 \"\") " 
  ) 
      ) 
      (list 
  (cons "label" "修改图层") 
  (cons 
    "macro" 
    "(vl-cmdf \"change\" (car(entsel)) \"\" \"P\" \"LA\" \"0\" \"\") " 
  ) 
      ) 
      (list 
  "修改2子级" 
  (list 
    (cons "label" "修改颜色") 
    (cons 
      "macro" 
      "(vl-cmdf \"change\" (car(entsel)) \"\" \"P\" \"C\" 2 \"\") " 
    ) 
  ) 
  (list 
    (cons "label" "修改图层") 
    (cons 
      "macro" 
      "(vl-cmdf \"change\" (car(entsel)) \"\" \"P\" \"LA\" \"0\" \"\") " 
    ) 
  ) 
      ) 
    ) 
  ) 
) 
(SETQ DATA (LIST ($you-jian-cai-dan-test$))) 
($chuang-jian-you-jian-cai-dan$ DATA "右键菜单测试" nil)

网友答: 为执行个简单的command整这么复杂，完全没有必要。单独定义个小lsp就行了。使用再高频，一个自定义lsp也可以两个字母的命令搞定一个特定功能，鼠标右键，还是要点一下，拖动找需要执行的命令，再点一下，操作便利上并没有提高。

网友答:

429014673 发表于 2025-10-7 00:38
Error: 类型不正确 - #
中望2026出错

应该是你文本格式没对，要改成ansi。我在2026测试可以。

网友答: 先收藏，用到的时候再按需要修改

网友答: Error: 类型不正确 - #<%catch-all-apply-error%>
中望2026出错

网友答: 收藏了谢谢大神

网友答: 不管了先收藏啊

网友答: thanks for sharing.................

网友答: 感谢杜总的分享！

网友答: 最好是图标也可以添加上去

上一篇：（求助）批量对单个或多个CAD对象扩展数据的读

下一篇：没有了