明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 8882|回复: 25

模仿ACAD2010 做了个图层隔离和全部解锁工具

  [复制链接]
发表于 2011-9-12 19:36 | 显示全部楼层 |阅读模式
本帖最后由 chlh_jd 于 2011-9-17 23:28 编辑

  1. ;;LayerISO & LayerunISO
  2. ;;color fade scale , 0~90 , fitable 50~75 .
  3. (setq #gsls_color_fade# 75)
  4. ;;
  5. (defun c:myLayISO (/ *error* om oc oe ss lst ssen la)
  6.   ;;by GSLS(SS) 2011-09-16
  7.   (setq om (getvar "MODEMACRO")
  8. oc (getvar "cmdecho")
  9. oe *error*
  10.   )
  11.   (defun *error* (msg)
  12.     (command)
  13.     (command)
  14.     (if (or (= msg "Function cancelled")
  15.      (= msg "quit / exit abort")
  16. )
  17.       (princ msg)
  18.       (princ (strcat "\n错误: " msg))
  19.     )
  20.     (setvar "MODEMACRO" om)
  21.     (setvar "cmdecho" oc)
  22.     (setq *error* oe)
  23.     (vla-EndUndoMark
  24.       (vla-get-ActiveDocument (vlax-get-acad-object))
  25.     )
  26.   )
  27.   (vla-startundomark
  28.     (vla-get-activedocument (vlax-get-acad-object))
  29.   )
  30.   (setvar "MODEMACRO" "选择要隔离的图层上的对象:")
  31.   (setvar "cmdecho" 0)
  32.   (setq ss (ssget))
  33.   (if ss
  34.     (progn
  35.       (setq ssen (ss2lst ss nil))
  36.       (foreach a ssen
  37. (if (not (member (setq la (dxf 8 (entget a))) lst))
  38.    (setq lst (cons la lst))
  39. )
  40.       )
  41.       (ss:layer:iso lst)
  42.     )
  43.     (princ "\n未选择对象,请重新执行命令.")
  44.   )
  45.   (vla-EndUndoMark
  46.     (vla-get-ActiveDocument (vlax-get-acad-object))
  47.   )
  48.   (setvar "MODEMACRO" om)
  49.   (setvar "cmdecho" oc)
  50.   (setq *error* oe)
  51.   (princ)
  52. )
  53. ;;
  54. (defun c:myLayUnISO (/ *error* oc oe)
  55.   ;;by GSLS(SS) 2011-09-16
  56.   (setq oc (getvar "cmdecho")
  57. oe *error*
  58.   )
  59.   (defun *error* (msg)
  60.     (command)
  61.     (command)
  62.     (if (or (= msg "Function cancelled")
  63.      (= msg "quit / exit abort")
  64. )
  65.       (princ msg)
  66.       (princ (strcat "\n错误: " msg))
  67.     )
  68.     (setvar "cmdecho" oc)
  69.     (setq *error* oe)
  70.     (vla-EndUndoMark
  71.       (vla-get-ActiveDocument (vlax-get-acad-object))
  72.     )
  73.   )
  74.   (vla-startundomark
  75.     (vla-get-activedocument (vlax-get-acad-object))
  76.   )
  77.   (ss:layer:uniso)
  78.   (ss:layer:on)
  79.   (vla-EndUndoMark
  80.     (vla-get-ActiveDocument (vlax-get-acad-object))
  81.   )
  82.   (setvar "cmdecho" oc)
  83.   (setq *error* oe)
  84.   (princ)
  85. )
  86. ;;;
  87. (defun ss:layer:ISO (l / las ent col lay tc)
  88.   (setq las (xyp-get-tblnext "LAYER"))
  89.   (while las
  90.     (setq lay (car las)
  91.    las (cdr las)
  92.    ent (entget (TblObjName "layer" lay))
  93.     )
  94.     (if (and (not (member lay l))
  95.       (/= (logand 1 (dxf 70 ent)) 1)
  96.       (/= (logand 2 (dxf 70 ent)) 2)
  97.       (> (dxf 62 ent) 0)
  98. )
  99.       (progn (setq col (dxf 62 ent)
  100.      tc  (dxf 420 ent)
  101.       )
  102.       (vlax-ldata-put "date" lay (list col tc))
  103.       (if tc
  104.         (setq col (ss:color:true:fade tc))
  105.         (setq col (ss:color:aci:fade col))
  106.       )
  107.       (Entmod
  108.         (ch-en (cons 420 col) (subst (cons 70 4) (cons 70 0) ent))
  109.       )
  110.       )
  111.     )
  112.   )
  113.   ;;ADD regen
  114.   ;_(setq ti (car (_VL-TIMES)))
  115.   ;|
  116.   (vla-regen (vla-get-ActiveDocument (vlax-get-acad-object))
  117.       acActiveViewport
  118.   )|;
  119.   ;_(princ(strcat"\n "(rtos(/ (- (car (_VL-TIMES)) ti) 1000.)2 4)" secs."))
  120. );;;
  121. (defun ss:layer:uniso (/ las lay ent col tc)
  122.   (setq las (xyp-get-tblnext "LAYER"))
  123.   (while las
  124.     (setq lay (car las)
  125.    las (cdr las)
  126.    ent (entget (TblObjName "layer" lay))
  127.     )
  128.     (if (and (= (logand 4 (dxf 70 ent)) 4)
  129.       (> (dxf 62 ent) 0)
  130. )
  131.       (progn
  132. (if (and (setq col (vlax-ldata-get "date" lay))
  133.    (setq tc (cadr col))
  134.      )
  135.    (setq
  136.      ent (ch-en (cons 62 (car col)) (ch-en (cons 420 tc) ent))
  137.    )
  138.    (setq ent (ch-en (cons 62 (car col))
  139.       (vl-remove (assoc 420 ent) ent)
  140.       )
  141.    )
  142. )
  143. (setq ent (ch-en (cons 70 0) ent))
  144. (vlax-ldata-delete "date" lay)
  145. (Entmod ent)
  146.       )
  147.     )
  148.   )
  149.   ;_(setq ti (car (_VL-TIMES)))
  150.   ;|
  151.   (vla-regen (vla-get-ActiveDocument (vlax-get-acad-object))
  152.       acActiveViewport
  153.   )|;
  154.   ;_(princ(strcat"\n "(rtos(/ (- (car (_VL-TIMES)) ti) 1000.)2 4)" secs."))
  155. );;;
  156. (defun ss:layer:on (/ las lay ent col)
  157.   (setq las (xyp-get-tblnext "LAYER"))
  158.   (foreach lay las
  159.     (setq ent (entget (TblObjName "layer" lay)))
  160.     (if (or (= (logand 1 (dxf 70 ent)) 1) (= (logand 2 (dxf 70 ent)) 2))
  161.       (princ (strcat "\n图层" lay "处于冻结状态**"))
  162.       (if (< (setq col (dxf 62 ent)) 0)
  163. (progn
  164.    (entmod (ch-en (cons 62 (- col)) ent))
  165.    (princ (strcat "\n图层" lay "已打开。"))
  166. )
  167.       )
  168.     )
  169.   )
  170. )
  171. ;;;
  172. (defun xyp-get-tblnext (table-name / lst d)
  173.   ;;by xyp1964
  174.   (while (setq d (tblnext table-name (null d)))
  175.     (setq lst (cons (dxf 2 d) lst))
  176.   )
  177.   (reverse lst)
  178. )
  179. ;;
  180. (defun dxf (co en)
  181.   (if(eq(type en)(quote ENAME))(setq en(entget en(quote("*")))))
  182.   (if(vl-consp co)(mapcar (function (lambda (x)(cdr (assoc x en))))co)
  183.     (cdr (assoc co en))))
  184. ;;
  185. (defun ch-en (co en /)
  186.   (if (eq (type en) (quote ename))
  187.     (setq en (entget en (list "*")))
  188.   )
  189.   (if (assoc (car co) en)
  190.     (subst co (assoc (car co) en) en)
  191.     (append en (list co))
  192.   )
  193. )
  194. ;;
  195. ;;; aci fade ->  true
  196. (defun ss:color:aci:fade (c / r h )
  197.   ;;by GSLS(SS)
  198.   ;;key fun ...
  199.   (setq r (lm:aci->rgb c))
  200.   (setq h (apply (function lm:rgb->hsl ) r)
  201. h (append (butlast h) (list (fix (round (* (last h) (- 100 #gsls_color_fade#) 0.01) 0))))
  202. )
  203.   (apply (function lm:rgb->true) (apply (function lm:hsl->rgb ) h))   
  204. )
  205. ;;; true fade -> true
  206. (defun ss:color:true:fade (c / r h )
  207.   ;;by GSLS(SS)
  208.   ;;key fun ...
  209.   (setq r (lm:true->rgb c))
  210.   (setq h (apply (function lm:rgb->hsl ) r)
  211. h (append (butlast h) (list (fix (round (* (last h) (- 100 #gsls_color_fade#) 0.01) 0))))
  212. )
  213.   (apply (function lm:rgb->true) (apply (function lm:hsl->rgb ) h))   
  214. )
  215. ;;
  216. (defun butlast(a)
  217.   (reverse (cdr(reverse a)))
  218.   )
  219. ;;
  220. (defun ss2lst (ss vla / a e i)
  221.   (if (= (type ss) (quote PICKSET))
  222.     (progn
  223.       (setq i -1)
  224.       (while (setq e (ssname ss (setq i (1+ i))))
  225. (if vla
  226.    (setq e (vlax-ename->vla-object e))
  227.    nil
  228. )
  229. (setq a (cons e a))
  230.       )
  231.     )
  232.     nil
  233.   )
  234. )
  235. ;;
  236. (defun round (a jd / b)
  237.   (setq b (expt 10.0 jd))
  238.   (/ (fix (+ (* a b) 0.5)) b)
  239. )
  240. ;;-----------------------------------
  241. ;;following codes written by LeeMac
  242. ;;copy from
  243. ;;          [url=http://www.lee-mac.com/colourconversion.html]http://www.lee-mac.com/colourconversion.html[/url]
  244. ;;

  245. ;; True -> RGB - Lee Mac 2011
  246. ;; Args: c - True Colour
  247. (defun LM:True->RGB ( c )
  248.   (list
  249.     (lsh (lsh (fix c)  8) -24)
  250.     (lsh (lsh (fix c) 16) -24)
  251.     (lsh (lsh (fix c) 24) -24)
  252.   )
  253. )
  254. ;; RGB -> True - Lee Mac 2011
  255. ;; Args: r,g,b - Red,Green,Blue values
  256. (defun LM:RGB->True ( r g b )
  257.   (+
  258.     (lsh (fix r) 16)
  259.     (lsh (fix g)  8)
  260.     (fix b)
  261.   )
  262. )
  263. ;; OLE -> True - Lee Mac 2011
  264. ;; Args: c - OLE Colour
  265. (defun LM:OLE->True ( c )
  266.   (+
  267.     (lsh (lsh (lsh (fix c) 24) -24) 16)
  268.     (lsh (lsh (lsh (fix c) 16) -24)  8)
  269.     (lsh (lsh (fix c)  8) -24)
  270.   )
  271. )
  272. ;; True -> OLE - Lee Mac 2011
  273. ;; Args: c - True Colour
  274. (defun LM:True->OLE ( c )
  275.   (+
  276.     (lsh (lsh (fix c)  8) -24)
  277.     (lsh (lsh (lsh (fix c) 16) -24)  8)
  278.     (lsh (lsh (lsh (fix c) 24) -24) 16)
  279.   )
  280. )
  281. ;; RGB -> HSL - Lee Mac 2011
  282. ;; Args: r,g,b - Red,Green,Blue values
  283. (defun LM:RGB->HSL ( r g b / _round d h l m n s )
  284.   (setq r (/ r 255.)
  285.         g (/ g 255.)
  286.         b (/ b 255.)
  287.         n (min r g b)
  288.         m (max r g b)
  289.         d (- m n)
  290.         l (/ (+ m n) 2.)
  291.   )
  292.   (defun _round ( n )
  293.     (fix (+ n (if (minusp n) -0.5 0.5)))
  294.   )
  295.   (mapcar '_round
  296.     (cond
  297.       ( (zerop d)
  298.         (list 0 0 (* m 100))
  299.       )
  300.       (t
  301.         (setq s (if (< l 0.5) (/ d (+ m n)) (/ d (- 2. m n))))
  302.         (setq h
  303.           (cond
  304.             ( (= g m) (+ (/ (- b r) d) 2))
  305.             ( (= b m) (+ (/ (- r g) d) 4))
  306.             ( (/ (- g b) d))
  307.           )
  308.         )
  309.         (list (rem (+ 360 (* h 60)) 360) (* s 100) (* l 100))
  310.       )
  311.     )
  312.   )
  313. )
  314. ;; HSL -> RGB - Lee Mac 2011
  315. ;; Args: 0 <= h <= 360, 0 <= s,l <= 100
  316. (defun LM:HSL->RGB ( h s l / _sub _round u v )
  317.   (setq h (/ h 360.)
  318.         s (/ s 100.)
  319.         l (/ l 100.)
  320.   )
  321.   (defun _sub ( u v h )
  322.     (setq h (rem (1+ h) 1))
  323.     (cond
  324.       ( (< (* 6 h) 1) (+ u (* 6 h (- v u))))
  325.       ( (< (* 2 h) 1) v)
  326.       ( (< (* 3 h) 2) (+ u (* 6 (- (/ 2. 3.) h) (- v u))))
  327.       ( u )
  328.     )
  329.   )
  330.   (defun _round ( n )
  331.     (fix (+ n (if (minusp n) -0.5 0.5)))
  332.   )
  333.   (mapcar '_round
  334.     (mapcar '* '(255 255 255)
  335.       (cond
  336.         ( (zerop s)
  337.           (list l l l)
  338.         )
  339.         ( (zerop l)
  340.          '(0 0 0)
  341.         )
  342.         (t
  343.           (setq v (if (< l 0.5) (* l (1+ s)) (- (+ l s) (* l s)))
  344.                 u (- (* 2 l) v)
  345.           )
  346.           (mapcar '(lambda ( h ) (_sub u v h)) (list (+ h (/ 1. 3.)) h (- h (/ 1. 3.))))
  347.         )
  348.       )
  349.     )
  350.   )
  351. )
  352. ;; True -> ACI - Lee Mac 2011
  353. ;; Args: c - True Colour
  354. (defun LM:True->ACI ( c / cObj aci ) (vl-load-com)
  355.   (if
  356.     (and
  357.       (setq cObj
  358.         (vla-getInterfaceObject (vlax-get-acad-object)
  359.           (strcat "AutoCAD.AcCmColor." (substr (getvar 'ACADVER) 1 2))
  360.         )
  361.       )
  362.       (not
  363.         (vl-catch-all-error-p
  364.           (vl-catch-all-apply 'vla-SetRGB (cons cObj (LM:True->RGB c)))
  365.         )
  366.       )
  367.     )
  368.     (setq aci (vla-get-ColorIndex cObj))
  369.   )
  370.   (if cObj (vlax-release-object cObj))
  371.   aci
  372. )
  373. ;; ACI -> True - Lee Mac 2011
  374. ;; Args: c - ACI (AutoCAD Colour Index) Colour
  375. (defun LM:ACI->True ( c / cObj tc ) (vl-load-com)
  376.   (if
  377.     (and (<= 1 c 255)
  378.       (setq cObj
  379.         (vla-getInterfaceObject (vlax-get-acad-object)
  380.           (strcat "AutoCAD.AcCmColor." (substr (getvar 'ACADVER) 1 2))
  381.         )
  382.       )
  383.       (not
  384.         (vl-catch-all-error-p
  385.           (vl-catch-all-apply 'vla-put-ColorIndex (list cObj c))
  386.         )
  387.       )
  388.     )
  389.     (setq tc (LM:RGB->True (vla-get-Red cObj) (vla-get-Green cObj) (vla-get-Blue cObj)))
  390.   )
  391.   (if cObj (vlax-release-object cObj))
  392.   tc
  393. )
  394. ;; ACI -> RGB - Lee Mac 2011
  395. ;; Args: c - ACI (AutoCAD Colour Index) Colour
  396. (defun LM:ACI->RGB ( c / cObj rgb ) (vl-load-com)
  397.   (if
  398.     (and (<= 1 c 255)
  399.       (setq cObj
  400.         (vla-getInterfaceObject (vlax-get-acad-object)
  401.           (strcat "AutoCAD.AcCmColor." (substr (getvar 'ACADVER) 1 2))
  402.         )
  403.       )
  404.       (not
  405.         (vl-catch-all-error-p
  406.           (vl-catch-all-apply 'vla-put-ColorIndex (list cObj c))
  407.         )
  408.       )
  409.     )
  410.     (setq rgb (list (vla-get-Red cObj) (vla-get-Green cObj) (vla-get-Blue cObj)))
  411.   )
  412.   (if cObj (vlax-release-object cObj))
  413.   rgb
  414. )
  415. ;; RGB -> ACI - Lee Mac 2011
  416. ;; Args: r,g,b - Red,Green,Blue values
  417. (defun LM:RGB->ACI ( r g b / cObj aci ) (vl-load-com)
  418.   (if
  419.     (and
  420.       (setq cObj
  421.         (vla-getInterfaceObject (vlax-get-acad-object)
  422.           (strcat "AutoCAD.AcCmColor." (substr (getvar 'ACADVER) 1 2))
  423.         )
  424.       )
  425.       (not
  426.         (vl-catch-all-error-p
  427.           (vl-catch-all-apply 'vla-SetRGB (list cObj r g b))
  428.         )
  429.       )
  430.     )
  431.     (setq aci (vla-get-ColorIndex cObj))
  432.   )
  433.   (if cObj (vlax-release-object cObj))
  434.   aci
  435. )

本帖子中包含更多资源

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

x

本帖被以下淘专辑推荐:

发表于 2011-9-12 20:34 | 显示全部楼层
发一个我很久以前发的源码.

  1. (defun gps->vla-layers ()
  2.   (cond
  3.     (#gps-vla-layers#)
  4.     ((setq #gps-vla-layers# (vla-get-layers #ActiveDocument#)))
  5.   )  
  6. )
  7. (defun c:gps_lay_ciso( / lays ss ss2 x);!!!图层凸显
  8. (if $clayiso_laystats (c:gps_lay_unciso) )
  9. (progn
  10.   (setq lays (gps->vla-Layers))
  11.   (vlax-map-collection
  12.           lays
  13.           '(lambda (x)
  14.              (setq $clayiso_laystats
  15.                     (append $clayiso_laystats
  16.                         (list (list x (vla-get-color x) (vla-get-lock x)))
  17.                     )
  18.              )
  19.           )
  20.   )
  21.   (princ "\n选择要凸显图层上的对象:")
  22.   (if (setq ss (ssget))
  23.     (progn
  24.         (setq
  25.           ss
  26.            (mapcar 'vlax-ename->vla-object
  27.                    (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
  28.            )
  29.         )
  30.         (mapcar '(lambda (x)
  31.                    (setq ss2 (cons (vla-get-layer x) ss2))
  32.                  )
  33.                 ss
  34.         )
  35.         (vlax-map-collection
  36.           lays
  37.           '(lambda (x)
  38.              (if (not (member (vla-get-name x) ss2))
  39.                 (progn
  40.                   (vla-put-color x 250)
  41.                   (vla-put-lock  x :vlax-true)
  42.                 )
  43.                 (vla-put-lock  x :vlax-false)
  44.              )
  45.            )
  46.         )         
  47.      )
  48.    )
  49. )
  50. (prin1)
  51. )
  52. ;;;------------------------------------------------------------------------------------------
  53. (defun c:gps_lay_unciso( / a b x);!!!恢复凸显
  54. (if $clayiso_laystats
  55.   (progn   
  56.     (mapcar
  57.       '(lambda (x)
  58.           (setq a (car x) b (cadr  x))
  59.           (if (vlax-write-enabled-p a)
  60.             (progn
  61.               (vla-put-color a b)
  62.               (vla-put-lock  a b)
  63.             )
  64.           )         
  65.        )      
  66.       $clayiso_laystats
  67.      )
  68.     (setq $clayiso_laystats nil)
  69.   )
  70. (princ "\n图层未凸显.")
  71. )
  72. (prin1)
  73. )
发表于 2011-9-12 20:52 | 显示全部楼层
"no function definition: SVOS"
发表于 2011-9-12 21:42 | 显示全部楼层
xshrimp 发表于 2011-9-12 20:34
发一个我很久以前发的源码.

Xshrimp,你的工具我一直在用,很好。不过和我们设计院的图框工具有冲突,非常郁闷!
发表于 2011-9-12 23:18 | 显示全部楼层
先收藏。。下次有空再研究研究。。。
发表于 2011-9-13 11:03 | 显示全部楼层
没有用10,可以简单说明一下吗
 楼主| 发表于 2011-9-14 04:40 | 显示全部楼层
本帖最后由 chlh_jd 于 2011-9-14 04:41 编辑

ACAD2010把原本在EXPRESS TOOLS 里面的几个图层管理工具加到了ACAD自身中,并做了扩充,其中包括图层隔离LAYISO和隔离图层恢复LAYUNISO,图层隔离时,ACAD通过对其他所有锁定图层上的实体进行淡色,也就是减少亮度,这个淡色比例在系统变量LAYLOCKFADECTL里面设置;这样使得非锁定图层操作时有更多的参照,方便使用。
发表于 2011-9-14 12:42 | 显示全部楼层
不错,必须顶.
发表于 2011-9-15 13:04 | 显示全部楼层
对,顶,必须顶!
发表于 2011-9-15 22:11 | 显示全部楼层
谢谢“chlh_jd”的源码,我顶
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-28 17:55 , Processed in 0.885479 second(s), 29 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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