拷贝选择的对象到新的图层

Lisphk

[JavaScript] 纯文本查看 复制代码

(defun c:c2lay ( / inc lay lst obj sel )
    (if (setq sel (ssget "_:L"))
        (progn
            (while (setq lay (tblnext "layer" (not lay)))
                (if (zerop (logand 52 (cdr (assoc 70 lay))))
                    (setq lst (cons (cdr (assoc 2 lay)) lst))
                )
            )
            (if (setq lst (LM:listbox "Select Layers to Copy to" (acad_strlsort lst) t))
                (repeat (setq inc (sslength sel))
                    (setq obj (vlax-ename->vla-object (ssname sel (setq inc (1- inc)))))
                    (foreach lay lst
                        (vla-put-layer (vla-copy obj) lay)
                    )
                )
                (princ "\n*Cancel*")
            )
        )
    )
    (princ)
)
(defun LM:listbox ( msg lst bit / dch des tmp rtn )
    (cond
        (   (not
                (and
                    (setq tmp (vl-filename-mktemp nil nil ".dcl"))
                    (setq des (open tmp "w"))
                    (write-line
                        (strcat "listbox:dialog{label=\"" msg "\";spacer;:list_box{key=\"list\";multiple_select="
                            (if (= 1 (logand 1 bit)) "true" "false") ";width=50;height=15;}spacer;ok_cancel;}"
                        )
                        des
                    )
                    (not (close des))
                    (< 0 (setq dch (load_dialog tmp)))
                    (new_dialog "listbox" dch)
                )
            )
            (prompt "\nError Loading List Box Dialog.")
        )
        (   t     
            (start_list "list")
            (foreach itm lst (add_list itm))
            (end_list)
            (setq rtn (set_tile "list" "0"))
            (action_tile "list" "(setq rtn $value)")
            (setq rtn
                (if (= 1 (start_dialog))
                    (if (= 2 (logand 2 bit))
                        (read (strcat "(" rtn ")"))
                        (mapcar '(lambda ( x ) (nth x lst)) (read (strcat "(" rtn ")")))
                    )
                )
            )
        )
    )
    (if (< 0 dch)
        (unload_dialog dch)
    )
    (if (and tmp (setq tmp (findfile tmp)))
        (vl-file-delete tmp)
    )
    rtn
)
(vl-load-com) (princ)

另外一个：

1. (defun c:tt (/ *error* showdcl on lst ss i sn vl)
   
2. ;;;--- Tharwat 25. May. 2013 ---;;;
   
3.   (or doc
   
4.       (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
   
5.   )
   
6.   (defun *error* (x)
   
7.     (if        doc
   
8.       (vla-endundomark doc)
   
9.     )
   
10.     (if        f
    
11.       (progn (close f) (vl-file-delete fn))
    
12.     )
    
13.     (princ "\n*Cancel*")
    
14.   )
    
15.   (defun ShowDcl (/ sn f str dcl_id l lays pos)
    
16.     (setq fn (vl-filename-mktemp "dcl.dcl"))
    
17.     (setq f (open fn "w"))
    
18.     (foreach str
    
19.              (list
    
20.                "Layers : dialog { label = \"Layer List\"; fixed_width = true;"
    
21.                ": list_box { label = \"Select Layer\"; key = \"layer\"; width = 32; multiple_select = true;}"
    
22.                ": boxed_row { label = \"Action\";" ": row {"
    
23.                ": button { label = \"Accept\"; key = \"accept\"; is_default = true;  }"
    
24.                ": button { label = \"Cancel\"; key = \"cancel\"; is_cancel = true; }}}}")
    
25.       (write-line str f)
    
26.     )
    
27.     (close f)
    
28.     (setq dcl_id (load_dialog fn))
    
29.     (if        (not (new_dialog "Layers" dcl_id))
    
30.       (exit)
    
31.     )
    
32.     (while (setq l (tblnext "LAYER" (not l)))
    
33.       (setq lays (cons (cdr (assoc 2 l)) lays))
    
34.     )
    
35.     (setq lays (reverse lays))
    
36.     (start_list "layer")
    
37.     (mapcar 'add_list lays)
    
38.     (end_list)
    
39.     (action_tile
    
40.       "accept"
    
41.       "(setq pos (get_tile \"layer\"))(done_dialog)"
    
42.     )
    
43.     (action_tile "cancel" "(done_dialog)")
    
44.     (start_dialog)
    
45.     (unload_dialog dcl_id)
    
46.     (if        pos
    
47.       (foreach n (read (strcat "(" pos ")"))
    
48.         (setq lst (cons (nth n lays) lst))
    
49.       )
    
50.     )
    
51.   )
    
52.   (if (and (progn (princ "\n Select Polyline ...")
    
53.                   (setq ss (ssget "_:L" '((0 . "*POLYLINE"))))
    
54.            )
    
55.            (setq on (ShowDcl))
    
56.       )
    
57.     (progn
    
58.       (vl-file-delete fn)
    
59.       (vla-StartUndomark doc)
    
60.       (repeat (setq i (sslength ss))
    
61.         (setq sn (ssname ss (setq i (1- i))))
    
62.         (foreach x lst
    
63.           (vla-copy (setq vl (vlax-ename->vla-object sn)))
    
64.           (vla-put-layer vl x)
    
65.         )
    
66.       )
    
67.       (vla-endundomark doc)
    
68.     )
    
69.   )
    
70.   (princ "\n Written By Tharwat Al Shoufi")
    
71.   (princ)
    
72. )
    
73. 
    

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

434939575

沙发 .谢谢分享。可能用处不太大，可以学习下。

kqqt6236

谢谢分享。

liunian0524

感谢大师分享