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

chlh_jd · 发表于 2011-9-12 19:36:19

本帖最后由 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
;; [url=http://www.lee-mac.com/colourconversion.html]http://www.lee-mac.com/colourconversion.html[/url]
;;
;; 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
)

;;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 
;;          [url=http://www.lee-mac.com/colourconversion.html]http://www.lee-mac.com/colourconversion.html[/url] 
;; 
 
;; 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 "<a href="http://bbs.mjtd.com/forum-41-1.html" target="_blank" class="relatedlink">AutoCAD</a>.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 
)

jdws213 · 发表于 2024-9-6 08:42:14

感谢楼主的资源，比ET的快多了

xshrimp · 发表于 2011-9-12 20:34:57

发一个我很久以前发的源码.

(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-lock x :vlax-true)
)
(vla-put-lock x :vlax-false)
)
)
)
)
)
)
(prin1)
)
;;;------------------------------------------------------------------------------------------
(defun c:gps_lay_unciso( / a b x);!!!恢复凸显
(if $clayiso_laystats
(progn
(mapcar
'(lambda (x)
(setq a (car x) b (cadr x))
(if (vlax-write-enabled-p a)
(progn
(vla-put-color a b)
(vla-put-lock a b)
)
)
)
$clayiso_laystats
)
(setq $clayiso_laystats nil)
)
(princ "\n图层未凸显.")
)
(prin1)
)

(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-lock  x :vlax-true) 
                ) 
                (vla-put-lock  x :vlax-false) 
             ) 
           ) 
        )          
     ) 
   ) 
 ) 
(prin1) 
) 
;;;------------------------------------------------------------------------------------------ 
(defun c:gps_lay_unciso( / a b x);!!!恢复凸显 
(if $clayiso_laystats 
  (progn    
    (mapcar 
      '(lambda (x) 
          (setq a (car x) b (cadr  x)) 
          (if (vlax-write-enabled-p a) 
            (progn 
              (vla-put-color a b) 
              (vla-put-lock  a b) 
            ) 
          )          
       )       
      $clayiso_laystats 
     ) 
    (setq $clayiso_laystats nil) 
  ) 
 (princ "\n图层未凸显.") 
) 
(prin1) 
)

yfeng17 · 发表于 2011-9-12 20:52:57

"no function definition: SVOS"

yjr111 · 发表于 2011-9-12 21:42:20

xshrimp 发表于 2011-9-12 20:34
发一个我很久以前发的源码.

Xshrimp,你的工具我一直在用，很好。不过和我们设计院的图框工具有冲突，非常郁闷！

another2121 · 发表于 2011-9-12 23:18:25

先收藏。。下次有空再研究研究。。。

doro · 发表于 2011-9-13 11:03:14

没有用10，可以简单说明一下吗

chlh_jd · 发表于 2011-9-14 04:40:13

本帖最后由 chlh_jd 于 2011-9-14 04:41 编辑

ACAD2010把原本在EXPRESS TOOLS 里面的几个图层管理工具加到了ACAD自身中，并做了扩充，其中包括图层隔离LAYISO和隔离图层恢复LAYUNISO,图层隔离时,ACAD通过对其他所有锁定图层上的实体进行淡色，也就是减少亮度，这个淡色比例在系统变量LAYLOCKFADECTL里面设置；这样使得非锁定图层操作时有更多的参照，方便使用。

LLXXZZ · 发表于 2011-9-14 12:42:48

不错,必须顶.

gbhsu · 发表于 2011-9-15 13:04:49

对,顶,必须顶!

USER2128 · 发表于 2011-9-15 22:11:40

谢谢“chlh_jd”的源码，我顶

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

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

本帖子中包含更多资源

本帖被以下淘专辑推荐: