[编程交流] lisp创建层并调用

;; Arguments:
;; tc  - TrueColour value (Integer)
;; lum - Luminance value (Integer 0 <= lum <= 100)
;; Returns: TrueColour value with Luminance set to value specified
(defun SetLuminance ( tc lum / hsl )
 ( (lambda ( hsl ) (apply 'LM:RGB->True (LM:HSL->RGB (car hsl) (cadr hsl) lum)))
   (apply 'LM:RGB->HSL (LM:True->RGB tc))
 )
)

(defun c:test ( / layer lst )
 (setq layer "Layer1")
 (if (setq lst (acad_truecolordlg '(62 . 7) nil))
   (entmake
     (list
       (cons 0 "LAYER")
       (cons 100 "AcDbSymbolTableRecord")
       (cons 100 "AcDbLayerTableRecord")
       (cons 2 layer)
       (cons 70 0)
       (cons 420 (SetLuminance (cdr (assoc 420 lst)) 50))
     )
   )
 )
 (princ)
)

landowner: dialog
{label = "Landowner Layer Creation";
   : edit_box 
            {
   label = "Enter landowner name :";
   key = "name";
   alignment = centered;
   edit_limit = 45;
   edit_width = 50;
   }
   : button    
   {
   key = "accept";
   label = "OK";
   is_default = true;
   fixed_width = true;
   alignment = centered;
   }
   : errtile
   {
   width = 34;
   }
}

(defun c:landowner (/ Layername LayerColor name)
(setq SUCE (getvar "cmdecho"))
 (setq SUOM (getvar "orthomode"))
 (setq SUSM (getvar "osmode"))
 (setq SUAB (getvar "angbase"))
 (setq SUAD (getvar "angdir"))
 (setq SUCL (getvar "clayer"))
 (setq SUCR (getvar "cecolor"))
(setq dcl_id (load_dialog "landowner.dcl"))
    (if (not (new_dialog "landowner" dcl_id))
    (exit)
    );if
(if *name1*
   (set_tile "name" *name1*)
   (set_tile "name" "Default")
 )
(action_tile "name" "(setq *name1* $value)")
(start_dialog)
(unload_dialog dcl_id)
(setq layername (strcat "CCC_LANDOWNER_"*name1*)
            LayerColor (acad_truecolordlg '(62 . 7) nil))
  (entmake (list (cons 0 "LAYER")
                (cons 100 "AcDbSymbolTableRecord")
                (cons 100 "AcDbLayerTableRecord")
                (cons 2 Layername)
                (car LayerColor) 
              (if (> (length LayerColor) 1)
                  (car (cdr LayerColor)))     
                (cons 70 0)
       (cons 420 (SetLuminance (cdr (assoc 420 lst)) 50))
   )
     )
)
(setvar "clayer" layername)
(command "._pline")
(while (= 1 (logand 1 (getvar "cmdactive")))
(command pause))
 (setq pline (entlast)
   elist (entget pline)
   )
(command "_chprop" pline "" "_color" (cdr (car LayerColor)) "" "")
(command "_.draworder" pline "" "_F");<--set pline's draw order to front 
 (setvar "hpname" "honey")
 (setvar "hpscale" 2)
 (command "-hatch" "S" pline "" "") 
 (setvar "hpname" ".")
 (setvar "cmdecho"   SUCE)
 (setvar "orthomode" SUOM)
 (setvar "osmode"    SUSM)
 (setvar "angbase"   SUAB)
 (setvar "angdir"    SUAD)
 (setvar "clayer"    SUCL)
 (setvar "cecolor"    SUCR)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun SetLuminance ( tc lum / hsl )
 ( (lambda ( hsl ) (apply 'LM:RGB->True (LM:HSL->RGB (car hsl) (cadr hsl) lum)))
   (apply 'LM:RGB->HSL (LM:True->RGB tc))
 )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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))
     )
   )
 )
)
;; 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)  
   (fix b)
 )
)
;; 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 -> RGB - Lee Mac 2011
;; Args: c - True Colour
(defun LM:True->RGB ( c )
 (list
   (lsh (lsh (fix c)   -24)
   (lsh (lsh (fix c) 16) -24)
   (lsh (lsh (fix c) 24) -24)
 )
)

(defun c:landowner ( / elast id lst name old vars )
 (setq vars '("CLAYER" "HPNAME" "HPSCALE")
       old   (mapcar 'getvar vars)
 )
 (cond
   ( (or
       (<= (setq id (load_dialog "landowner.dcl")) 0)
       (not (new_dialog "landowner" id))
     )
     (princ "\n--> Error Loading Dialog.")
   )
   (t
     (set_tile "name" (cond (*name1*) ("Default")))
     (action_tile "name" "(setq *name1* $value)")
    
     (if
       (and
         (= 1 (start_dialog))
         (setq lst (acad_truecolordlg '(62 . 7) nil))
       )
       (progn
         (setq name (strcat "CCC_LANDOWNER_"*name1*))
         (if (null (tblsearch "LAYER" name))
           (entmake
             (list
               (cons 0 "LAYER")
               (cons 100 "AcDbSymbolTableRecord")
               (cons 100 "AcDbLayerTableRecord")
               (cons 2 name)
               (cons 70 0)
               (cond
                 ( (assoc 420 lst)
                   (cons 420 (SetLuminance (cdr (assoc 420 lst)) 50))
                 )
                 ( (assoc 62 lst) )
               )
             )
           )
         )
         (setvar 'CLAYER name)
         (setq elast (entlast))
         (command "_.pline")
         (while (= 1 (logand 1 (getvar 'CMACTIVE))) (command pause))
         (if (not (equal elast (setq elast (entlast))))
           (progn
             (command "_.draworder" elast "" "_F")
             (setvar 'HPNAME "honey")
             (setvar 'HPSCALE 2)
             (command "_.-hatch" "_S" elast "" "")
             (setvar 'HPNAME ".")
           )
         )
       )
     )
   )
 )
 (if (< 0 id) (unload_dialog id))
 (mapcar 'setvar vars old)
 (princ)
)

landowner: dialog
{label = "Landowner Layer Creation";
   : edit_box 
            {
   label = "Enter landowner name :";
   key = "name";
   alignment = centered;
   edit_limit = 45;
   edit_width = 50;
   }
   : button    
   {
   key = "accept";
   label = "OK";
   is_default = true;
   fixed_width = true;
   alignment = centered;
   }
   : errtile
   {
   width = 34;
   }
}

(setq lst (acad_colordlg 1 nil))

;; 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
)

14