快速创建工具条

dcl1214 · 发表于 2025-10-21 13:43:19

本帖最后由 dcl1214 于 2025-10-21 14:34 编辑

(defun $add-ToolBar$ (MenuGroup-N Toolbar-N data
lst / a
barbutton-obj bitmaps
bmp-f i menugroup-obj
mnu-f png toolbar-bars
toolbar-new toolbars-obj PNG-STR
)
;($add-ToolBar$ nil nil nil nil)
(or MenuGroup-N (SETQ MenuGroup-N "Changli"))
(or Toolbar-N (SETQ Toolbar-N "YZ"))
(or data
(setq data (list
(LIST (CONS "功能" "画线")
(cons "快捷键" "(vl-cmdf \"line\")")
(cons "提示语" "鼠标靠上来命令行下面显示提示语")
(cons "图标" "fzd.bmp")
)
(LIST (CONS "功能" "画圆")
(cons "快捷键" "(vl-cmdf \"CIRCLE\")")
(cons "提示语" "鼠标靠上来命令行下面显示提示语")
(cons "图标" "fzd.bmp")
)
)
)
)
(SETQ MenuGroup-obj
(vl-catch-all-apply
'vla-Item
(list (vla-get-MenuGroups (vlax-get-Acad-Object))
MenuGroup-N
)
)
)
(IF (vl-catch-all-error-p MenuGroup-obj)
(SETQ MenuGroup-obj NIL)
)
(setq Toolbar-bars nil)
(if MenuGroup-obj
(setq toolbars-obj
(vl-catch-all-apply
'vla-get-toolbars
(LIST
MenuGroup-obj
)
)
)
)
(IF MenuGroup-obj
(vlax-for x toolbars-obj
(setq Toolbar-bars (cons (vla-get-name x) Toolbar-bars))
)
(PRINT "没有安装中线CAD")
)
(IF (or (vl-position (STRCASE Toolbar-N T) Toolbar-bars)
(vl-position Toolbar-N Toolbar-bars)
)
(vla-delete
(vl-catch-all-apply
'vla-Item
(list toolbars-obj
Toolbar-N
)
)
)
(progn
(setq Bitmaps nil)
(setq ToolBar-NEW
(vl-catch-all-apply
'vla-Add
(list toolbars-obj Toolbar-N)
)
)
(setq i 0)
(while (setq a (car data))
(setq barButton-obj
(vl-catch-all-apply
'vla-AddToolbarButton
(list
ToolBar-NEW
i
(cdr (assoc "功能" a))
(cdr (assoc "提示语" a))
(strcat
"(if c:yz()(vl-catch-all-apply 'load(list(findfile \"yz.vlx\"))))"
(cdr (assoc "快捷键" a))
" "
)
0
)
)
)
(setq png(SETQ PNG-STR (cdr (assoc "图标" a))))
(if png
(if (and png (setq png (findfile png)))
(progn
(vla-GetBitmaps
barButton-obj
'SmallBitmapName
'LargeBitmapName
)
(vla-SetBitmaps
barButton-obj
png
png
)
)
(print (strcat "没有找到: " png-STR))
)
)
(setq i (1+ i))
(setq data (cdr data))
)
(vl-catch-all-apply 'vla-put-Visible(list ToolBar-NEW :vlax-true))
)
)
(vl-catch-all-apply
'vlax-release-object
(list MenuGroup-obj)
)
(vl-catch-all-apply
'vlax-release-object
(list toolbars-obj)
)
(vl-catch-all-apply 'vlax-release-object (list ToolBar-NEW))
(setq MenuGroup-obj nil
toolbars-obj nil
ToolBar-NEW nil
)
(gc)
)

(defun $add-ToolBar$ (MenuGroup-N  Toolbar-N  data 
          lst     /    a 
          barbutton-obj    bitmaps 
          bmp-f     i    menugroup-obj 
          mnu-f     png    toolbar-bars 
          toolbar-new  toolbars-obj PNG-STR 
         ) 
          ;($add-ToolBar$ nil nil nil nil) 
  (or MenuGroup-N (SETQ MenuGroup-N "Changli")) 
  (or Toolbar-N (SETQ Toolbar-N "YZ")) 
  (or data 
      (setq data (list 
       (LIST (CONS "功能" "画线") 
       (cons "快捷键" "(vl-cmdf \"line\")") 
       (cons "提示语" "鼠标靠上来命令行下面显示提示语") 
       (cons "图标" "fzd.bmp") 
       ) 
       (LIST (CONS "功能" "画圆") 
       (cons "快捷键" "(vl-cmdf \"CIRCLE\")") 
       (cons "提示语" "鼠标靠上来命令行下面显示提示语") 
       (cons "图标" "fzd.bmp") 
       ) 
     ) 
      ) 
  ) 
  (SETQ  MenuGroup-obj 
   (vl-catch-all-apply 
     'vla-Item 
     (list (vla-get-MenuGroups (vlax-get-Acad-Object)) 
     MenuGroup-N 
     ) 
   ) 
  ) 
  (IF (vl-catch-all-error-p MenuGroup-obj) 
    (SETQ MenuGroup-obj NIL) 
  ) 
  (setq Toolbar-bars nil) 
  (if MenuGroup-obj 
    (setq toolbars-obj 
     (vl-catch-all-apply 
       'vla-get-toolbars 
       (LIST 
         MenuGroup-obj 
       ) 
     ) 
    ) 
  ) 
  (IF MenuGroup-obj 
    (vlax-for x  toolbars-obj 
      (setq Toolbar-bars (cons (vla-get-name x) Toolbar-bars)) 
    ) 
    (PRINT "没有安装中线CAD") 
  ) 
  (IF (or (vl-position (STRCASE Toolbar-N T) Toolbar-bars) 
    (vl-position Toolbar-N Toolbar-bars) 
      ) 
    (vla-delete 
      (vl-catch-all-apply 
  'vla-Item 
  (list toolbars-obj 
        Toolbar-N 
  ) 
      ) 
    ) 
    (progn 
      (setq Bitmaps nil) 
      (setq ToolBar-NEW 
       (vl-catch-all-apply 
         'vla-Add 
         (list toolbars-obj Toolbar-N) 
       ) 
      ) 
      (setq i 0) 
      (while (setq a (car data)) 
  (setq barButton-obj 
         (vl-catch-all-apply 
     'vla-AddToolbarButton 
     (list 
       ToolBar-NEW 
       i 
       (cdr (assoc "功能" a)) 
       (cdr (assoc "提示语" a)) 
       (strcat 
         "(if c:yz()(vl-catch-all-apply 'load(list(findfile \"yz.vlx\"))))" 
         (cdr (assoc "快捷键" a)) 
         " " 
       ) 
       0 
     ) 
         ) 
  ) 
  (setq png(SETQ PNG-STR (cdr (assoc "图标" a)))) 
  (if png 
    (if (and png (setq png (findfile png))) 
      (progn 
        (vla-GetBitmaps 
    barButton-obj 
    'SmallBitmapName 
    'LargeBitmapName 
        ) 
        (vla-SetBitmaps 
    barButton-obj 
    png 
    png 
        ) 
      ) 
      (print (strcat "没有找到: " png-STR)) 
    ) 
  ) 
  (setq i (1+ i)) 
  (setq data (cdr data)) 
      ) 
      (vl-catch-all-apply 'vla-put-Visible(list ToolBar-NEW :vlax-true)) 
    ) 
  ) 
  (vl-catch-all-apply 
    'vlax-release-object 
    (list MenuGroup-obj) 
  ) 
  (vl-catch-all-apply 
    'vlax-release-object 
    (list toolbars-obj) 
  ) 
  (vl-catch-all-apply 'vlax-release-object (list ToolBar-NEW)) 
  (setq  MenuGroup-obj nil 
  toolbars-obj  nil 
  ToolBar-NEW   nil 
  ) 
  (gc) 
)

664571221 · 发表于 2025-10-23 10:15:43

sachindkini 发表于 2025-10-21 14:36
thanks for sharing

WHERE ARE YOU FROM

664571221 · 发表于 2025-10-23 16:23:50

sachindkini 发表于 2025-10-23 13:30
我来自印度

是天竺的那个印度吗

sachindkini · 发表于 2025-10-23 13:30:44

664571221 发表于 2025-10-23 10:15
WHERE ARE YOU FROM

我来自印度

qifeifei · 发表于 2025-10-21 13:48:35

非常感谢分享刚好需要这个

qwsss31 · 发表于 2025-10-21 14:03:33

源码好定西

sachindkini · 发表于 2025-10-21 14:36:44

thanks for sharing

菜鸟初来乍到 · 发表于 2025-10-21 14:50:38

感谢大佬分享

tranque · 发表于 2025-10-21 15:09:35

源码好东西

zjy2999 · 发表于 2025-10-21 16:36:30

感谢大佬分享

oysheji · 发表于 2025-10-21 18:57:31

感谢大佬的分享

潘成祥2015 · 发表于 2025-10-22 12:44:18

怎么用的呀

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

[经验] 快速创建工具条

评分