[编程交流] 将对象复制到新图层

(Command "CopyToLayer")

(defun c:Test (/ *error* showdcl on lst ss i sn vl)
;;;--- Tharwat 25. May. 2013 ---;;;
 (or doc
     (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
 )
 (defun *error* (x)
   (if doc
     (vla-endundomark doc)
   )
   (if f
     (progn (close f) (vl-file-delete fn))
   )
   (princ "\n*Cancel*")
 )
 (defun ShowDcl (/ sn f str dcl_id l lays pos)
   (setq fn (vl-filename-mktemp "dcl.dcl"))
   (setq f (open fn "w"))
   (foreach str
            (list
              "Layers : dialog { label = "Layer List"; fixed_width = true;"
              ": list_box { label = "Select Layer"; key = "layer"; width = 32; multiple_select = true;}"
              ": boxed_row { label = "Action";" ": row {"
              ": button { label = "Accept"; key = "accept"; is_default = true;  }"
              ": button { label = "Cancel"; key = "cancel"; is_cancel = true; }}}}")
     (write-line str f)
   )
   (close f)
   (setq dcl_id (load_dialog fn))
   (if (not (new_dialog "Layers" dcl_id))
     (exit)
   )
   (while (setq l (tblnext "LAYER" (not l)))
     (setq lays (cons (cdr (assoc 2 l)) lays))
   )
   (setq lays (reverse lays))
   (start_list "layer")
   (mapcar 'add_list lays)
   (end_list)
   (action_tile
     "accept"
     "(setq pos (get_tile "layer"))(done_dialog)"
   )
   (action_tile "cancel" "(done_dialog)")
   (start_dialog)
   (unload_dialog dcl_id)
   (if pos
     (foreach n (read (strcat "(" pos ")"))
       (setq lst (cons (nth n lays) lst))
     )
   )
 )
 (if (and (progn (princ "\n Select Polyline ...")
                 (setq ss (ssget "_:L" '((0 . "*POLYLINE"))))
          )
          (setq on (ShowDcl))
     )
   (progn
     (vl-file-delete fn)
     (vla-StartUndomark doc)
     (repeat (setq i (sslength ss))
       (setq sn (ssname ss (setq i (1- i))))
       (foreach x lst
         (vla-copy (setq vl (vlax-ename->vla-object sn)))
         (vla-put-layer vl x)
       )
     )
     (vla-endundomark doc)
   )
 )
 (princ "\n Written By Tharwat Al Shoufi")
 (princ)
)

([color=BLUE]defun[/color] c:c2lay ( [color=BLUE]/[/color] inc lay lst obj sel )
   ([color=BLUE]if[/color] ([color=BLUE]setq[/color] sel ([color=BLUE]ssget[/color] [color=MAROON]"_:L"[/color]))
       ([color=BLUE]progn[/color]
           ([color=BLUE]while[/color] ([color=BLUE]setq[/color] lay ([color=BLUE]tblnext[/color] [color=MAROON]"layer"[/color] ([color=BLUE]not[/color] lay)))
               ([color=BLUE]if[/color] ([color=BLUE]zerop[/color] ([color=BLUE]logand[/color] 52 ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 70 lay))))
                   ([color=BLUE]setq[/color] lst ([color=BLUE]cons[/color] ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 2 lay)) lst))
               )
           )
           ([color=BLUE]if[/color] ([color=BLUE]setq[/color] lst (LM:listbox [color=MAROON]"Select Layers to Copy to"[/color] ([color=BLUE]acad_strlsort[/color] lst) [color=BLUE]t[/color]))
               ([color=BLUE]repeat[/color] ([color=BLUE]setq[/color] inc ([color=BLUE]sslength[/color] sel))
                   ([color=BLUE]setq[/color] obj ([color=BLUE]vlax-ename->vla-object[/color] ([color=BLUE]ssname[/color] sel ([color=BLUE]setq[/color] inc ([color=BLUE]1-[/color] inc)))))
                   ([color=BLUE]foreach[/color] lay lst
                       ([color=BLUE]vla-put-layer[/color] ([color=BLUE]vla-copy[/color] obj) lay)
                   )
               )
               ([color=BLUE]princ[/color] [color=MAROON]"\n*Cancel*"[/color])
           )
       )
   )
   ([color=BLUE]princ[/color])
)
([color=BLUE]vl-load-com[/color]) ([color=BLUE]princ[/color])