模仿ACAD2010 做了个图层隔离和全部解锁工具
本帖最后由 chlh_jd 于 2011-9-17 23:28 编辑;;LayerISO & LayerunISO
;;color fade scale , 0~90 , fitable 50~75 .
(setq #gsls_color_fade# 75)
;;
(defun c:myLayISO (/ *error* om oc oe ss lst ssen la)
;;by GSLS(SS) 2011-09-16
(setq om (getvar "MODEMACRO")
oc (getvar "cmdecho")
oe *error*
)
(defun *error* (msg)
(command)
(command)
(if (or (= msg "Function cancelled")
(= msg "quit / exit abort")
)
(princ msg)
(princ (strcat "\n错误: " msg))
)
(setvar "MODEMACRO" om)
(setvar "cmdecho" oc)
(setq *error* oe)
(vla-EndUndoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
)
(vla-startundomark
(vla-get-activedocument (vlax-get-acad-object))
)
(setvar "MODEMACRO" "选择要隔离的图层上的对象:")
(setvar "cmdecho" 0)
(setq ss (ssget))
(if ss
(progn
(setq ssen (ss2lst ss nil))
(foreach a ssen
(if (not (member (setq la (dxf 8 (entget a))) lst))
(setq lst (cons la lst))
)
)
(ss:layer:iso lst)
)
(princ "\n未选择对象，请重新执行命令.")
)
(vla-EndUndoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(setvar "MODEMACRO" om)
(setvar "cmdecho" oc)
(setq *error* oe)
(princ)
)
;;
(defun c:myLayUnISO (/ *error* oc oe)
;;by GSLS(SS) 2011-09-16
(setq oc (getvar "cmdecho")
oe *error*
)
(defun *error* (msg)
(command)
(command)
(if (or (= msg "Function cancelled")
(= msg "quit / exit abort")
)
(princ msg)
(princ (strcat "\n错误: " msg))
)
(setvar "cmdecho" oc)
(setq *error* oe)
(vla-EndUndoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
)
(vla-startundomark
(vla-get-activedocument (vlax-get-acad-object))
)
(ss:layer:uniso)
(ss:layer:on)
(vla-EndUndoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(setvar "cmdecho" oc)
(setq *error* oe)
(princ)
)
;;;
(defun ss:layer:ISO (l / las ent col lay tc)
(setq las (xyp-get-tblnext "LAYER"))
(while las
(setq lay (car las)
las (cdr las)
ent (entget (TblObjName "layer" lay))
)
(if (and (not (member lay l))
(/= (logand 1 (dxf 70 ent)) 1)
(/= (logand 2 (dxf 70 ent)) 2)
(> (dxf 62 ent) 0)
)
(progn (setq col (dxf 62 ent)
tc(dxf 420 ent)
)
(vlax-ldata-put "date" lay (list col tc))
(if tc
(setq col (ss:color:true:fade tc))
(setq col (ss:color:aci:fade col))
)
(Entmod
(ch-en (cons 420 col) (subst (cons 70 4) (cons 70 0) ent))
)
)
)
)
;;ADD regen
;_(setq ti (car (_VL-TIMES)))
;|
(vla-regen (vla-get-ActiveDocument (vlax-get-acad-object))
acActiveViewport
)|;
;_(princ(strcat"\n "(rtos(/ (- (car (_VL-TIMES)) ti) 1000.)2 4)" secs."))
);;;
(defun ss:layer:uniso (/ las lay ent col tc)
(setq las (xyp-get-tblnext "LAYER"))
(while las
(setq lay (car las)
las (cdr las)
ent (entget (TblObjName "layer" lay))
)
(if (and (= (logand 4 (dxf 70 ent)) 4)
(> (dxf 62 ent) 0)
)
(progn
(if (and (setq col (vlax-ldata-get "date" lay))
(setq tc (cadr col))
)
(setq
ent (ch-en (cons 62 (car col)) (ch-en (cons 420 tc) ent))
)
(setq ent (ch-en (cons 62 (car col))
(vl-remove (assoc 420 ent) ent)
)
)
)
(setq ent (ch-en (cons 70 0) ent))
(vlax-ldata-delete "date" lay)
(Entmod ent)
)
)
)
;_(setq ti (car (_VL-TIMES)))
;|
(vla-regen (vla-get-ActiveDocument (vlax-get-acad-object))
acActiveViewport
)|;
;_(princ(strcat"\n "(rtos(/ (- (car (_VL-TIMES)) ti) 1000.)2 4)" secs."))
);;;
(defun ss:layer:on (/ las lay ent col)
(setq las (xyp-get-tblnext "LAYER"))
(foreach lay las
(setq ent (entget (TblObjName "layer" lay)))
(if (or (= (logand 1 (dxf 70 ent)) 1) (= (logand 2 (dxf 70 ent)) 2))
(princ (strcat "\n图层" lay "处于冻结状态**"))
(if (< (setq col (dxf 62 ent)) 0)
(progn
(entmod (ch-en (cons 62 (- col)) ent))
(princ (strcat "\n图层" lay "已打开。"))
)
)
)
)
)
;;;
(defun xyp-get-tblnext (table-name / lst d)
;;by xyp1964
(while (setq d (tblnext table-name (null d)))
(setq lst (cons (dxf 2 d) lst))
)
(reverse lst)
)
;;
(defun dxf (co en)
(if(eq(type en)(quote ENAME))(setq en(entget en(quote("*")))))
(if(vl-consp co)(mapcar (function (lambda (x)(cdr (assoc x en))))co)
(cdr (assoc co en))))
;;
(defun ch-en (co en /)
(if (eq (type en) (quote ename))
(setq en (entget en (list "*")))
)
(if (assoc (car co) en)
(subst co (assoc (car co) en) en)
(append en (list co))
)
)
;;
;;; aci fade ->true
(defun ss:color:aci:fade (c / r h )
;;by GSLS(SS)
;;key fun ...
(setq r (lm:aci->rgb c))
(setq h (apply (function lm:rgb->hsl ) r)
h (append (butlast h) (list (fix (round (* (last h) (- 100 #gsls_color_fade#) 0.01) 0))))
)
(apply (function lm:rgb->true) (apply (function lm:hsl->rgb ) h))
)
;;; true fade -> true
(defun ss:color:true:fade (c / r h )
;;by GSLS(SS)
;;key fun ...
(setq r (lm:true->rgb c))
(setq h (apply (function lm:rgb->hsl ) r)
h (append (butlast h) (list (fix (round (* (last h) (- 100 #gsls_color_fade#) 0.01) 0))))
)
(apply (function lm:rgb->true) (apply (function lm:hsl->rgb ) h))
)
;;
(defun butlast(a)
(reverse (cdr(reverse a)))
)
;;
(defun ss2lst (ss vla / a e i)
(if (= (type ss) (quote PICKSET))
(progn
(setq i -1)
(while (setq e (ssname ss (setq i (1+ i))))
(if vla
(setq e (vlax-ename->vla-object e))
nil
)
(setq a (cons e a))
)
)
nil
)
)
;;
(defun round (a jd / b)
(setq b (expt 10.0 jd))
(/ (fix (+ (* a b) 0.5)) b)
)
;;-----------------------------------
;;following codes written by LeeMac
;;copy from
;; http://www.lee-mac.com/colourconversion.html
;;
;; True -> RGB - Lee Mac 2011
;; Args: c - True Colour
(defun LM:True->RGB ( c )
(list
(lsh (lsh (fix c)8) -24)
(lsh (lsh (fix c) 16) -24)
(lsh (lsh (fix c) 24) -24)
)
)
;; RGB -> True - Lee Mac 2011
;; Args: r,g,b - Red,Green,Blue values
(defun LM:RGB->True ( r g b )
(+
(lsh (fix r) 16)
(lsh (fix g)8)
(fix b)
)
)
;; OLE -> True - Lee Mac 2011
;; Args: c - OLE Colour
(defun LM:OLE->True ( c )
(+
(lsh (lsh (lsh (fix c) 24) -24) 16)
(lsh (lsh (lsh (fix c) 16) -24)8)
(lsh (lsh (fix c)8) -24)
)
)
;; True -> OLE - Lee Mac 2011
;; Args: c - True Colour
(defun LM:True->OLE ( c )
(+
(lsh (lsh (fix c)8) -24)
(lsh (lsh (lsh (fix c) 16) -24)8)
(lsh (lsh (lsh (fix c) 24) -24) 16)
)
)
;; RGB -> HSL - Lee Mac 2011
;; Args: r,g,b - Red,Green,Blue values
(defun LM:RGB->HSL ( r g b / _round d h l m n s )
(setq r (/ r 255.)
g (/ g 255.)
b (/ b 255.)
n (min r g b)
m (max r g b)
d (- m n)
l (/ (+ m n) 2.)
)
(defun _round ( n )
(fix (+ n (if (minusp n) -0.5 0.5)))
)
(mapcar '_round
(cond
( (zerop d)
(list 0 0 (* m 100))
)
(t
(setq s (if (< l 0.5) (/ d (+ m n)) (/ d (- 2. m n))))
(setq h
(cond
( (= g m) (+ (/ (- b r) d) 2))
( (= b m) (+ (/ (- r g) d) 4))
( (/ (- g b) d))
)
)
(list (rem (+ 360 (* h 60)) 360) (* s 100) (* l 100))
)
)
)
)
;; HSL -> RGB - Lee Mac 2011
;; Args: 0 <= h <= 360, 0 <= s,l <= 100
(defun LM:HSL->RGB ( h s l / _sub _round u v )
(setq h (/ h 360.)
s (/ s 100.)
l (/ l 100.)
)
(defun _sub ( u v h )
(setq h (rem (1+ h) 1))
(cond
( (< (* 6 h) 1) (+ u (* 6 h (- v u))))
( (< (* 2 h) 1) v)
( (< (* 3 h) 2) (+ u (* 6 (- (/ 2. 3.) h) (- v u))))
( u )
)
)
(defun _round ( n )
(fix (+ n (if (minusp n) -0.5 0.5)))
)
(mapcar '_round
(mapcar '* '(255 255 255)
(cond
( (zerop s)
(list l l l)
)
( (zerop l)
'(0 0 0)
)
(t
(setq v (if (< l 0.5) (* l (1+ s)) (- (+ l s) (* l s)))
u (- (* 2 l) v)
)
(mapcar '(lambda ( h ) (_sub u v h)) (list (+ h (/ 1. 3.)) h (- h (/ 1. 3.))))
)
)
)
)
)
;; True -> ACI - Lee Mac 2011
;; Args: c - True Colour
(defun LM:True->ACI ( c / cObj aci ) (vl-load-com)
(if
(and
(setq cObj
(vla-getInterfaceObject (vlax-get-acad-object)
(strcat "AutoCAD.AcCmColor." (substr (getvar 'ACADVER) 1 2))
)
)
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-SetRGB (cons cObj (LM:True->RGB c)))
)
)
)
(setq aci (vla-get-ColorIndex cObj))
)
(if cObj (vlax-release-object cObj))
aci
)
;; ACI -> True - Lee Mac 2011
;; Args: c - ACI (AutoCAD Colour Index) Colour
(defun LM:ACI->True ( c / cObj tc ) (vl-load-com)
(if
(and (<= 1 c 255)
(setq cObj
(vla-getInterfaceObject (vlax-get-acad-object)
(strcat "AutoCAD.AcCmColor." (substr (getvar 'ACADVER) 1 2))
)
)
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-put-ColorIndex (list cObj c))
)
)
)
(setq tc (LM:RGB->True (vla-get-Red cObj) (vla-get-Green cObj) (vla-get-Blue cObj)))
)
(if cObj (vlax-release-object cObj))
tc
)
;; ACI -> RGB - Lee Mac 2011
;; Args: c - ACI (AutoCAD Colour Index) Colour
(defun LM:ACI->RGB ( c / cObj rgb ) (vl-load-com)
(if
(and (<= 1 c 255)
(setq cObj
(vla-getInterfaceObject (vlax-get-acad-object)
(strcat "AutoCAD.AcCmColor." (substr (getvar 'ACADVER) 1 2))
)
)
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-put-ColorIndex (list cObj c))
)
)
)
(setq rgb (list (vla-get-Red cObj) (vla-get-Green cObj) (vla-get-Blue cObj)))
)
(if cObj (vlax-release-object cObj))
rgb
)
;; RGB -> ACI - Lee Mac 2011
;; Args: r,g,b - Red,Green,Blue values
(defun LM:RGB->ACI ( r g b / cObj aci ) (vl-load-com)
(if
(and
(setq cObj
(vla-getInterfaceObject (vlax-get-acad-object)
(strcat "AutoCAD.AcCmColor." (substr (getvar 'ACADVER) 1 2))
)
)
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-SetRGB (list cObj r g b))
)
)
)
(setq aci (vla-get-ColorIndex cObj))
)
(if cObj (vlax-release-object cObj))
aci
)
感谢楼主的资源，比ET的快多了
发一个我很久以前发的源码.
(defun gps->vla-layers ()
(cond
(#gps-vla-layers#)
((setq #gps-vla-layers# (vla-get-layers #ActiveDocument#)))
)
)
(defun c:gps_lay_ciso( / lays ss ss2 x);!!!图层凸显
(if $clayiso_laystats (c:gps_lay_unciso) )
(progn
(setq lays (gps->vla-Layers))
(vlax-map-collection
lays
'(lambda (x)
(setq $clayiso_laystats
(append $clayiso_laystats
(list (list x (vla-get-color x) (vla-get-lock x)))
)
)
)
)
(princ "\n选择要凸显图层上的对象:")
(if (setq ss (ssget))
(progn
(setq
ss
(mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(mapcar '(lambda (x)
(setq ss2 (cons (vla-get-layer x) ss2))
)
ss
)
(vlax-map-collection
lays
'(lambda (x)
(if (not (member (vla-get-name x) ss2))
(progn
(vla-put-color x 250)
(vla-put-lockx :vlax-true)
)
(vla-put-lockx :vlax-false)
)
)
)
)
)
)
(prin1)
)
;;;------------------------------------------------------------------------------------------
(defun c:gps_lay_unciso( / a b x);!!!恢复凸显
(if $clayiso_laystats
(progn
(mapcar
'(lambda (x)
(setq a (car x) b (cadrx))
(if (vlax-write-enabled-p a)
(progn
(vla-put-color a b)
(vla-put-locka b)
)
)
)
$clayiso_laystats
)
(setq $clayiso_laystats nil)
)
(princ "\n图层未凸显.")
)
(prin1)
) "no function definition: SVOS"
xshrimp 发表于 2011-9-12 20:34 static/image/common/back.gif
发一个我很久以前发的源码.
Xshrimp,你的工具我一直在用，很好。不过和我们设计院的图框工具有冲突，非常郁闷！ 先收藏。。下次有空再研究研究。。。 没有用10，可以简单说明一下吗 本帖最后由 chlh_jd 于 2011-9-14 04:41 编辑
ACAD2010把原本在EXPRESS TOOLS 里面的几个图层管理工具加到了ACAD自身中，并做了扩充，其中包括图层隔离LAYISO和隔离图层恢复LAYUNISO,图层隔离时,ACAD通过对其他所有锁定图层上的实体进行淡色，也就是减少亮度，这个淡色比例在系统变量LAYLOCKFADECTL里面设置；这样使得非锁定图层操作时有更多的参照，方便使用。
不错,必须顶. 对,顶,必须顶! 谢谢“chlh_jd”的源码，我顶