修改XREF名字

Lisphk

1. (defun c:xren ( / AT:ListSelect adoc bl bll xrl pthl pth xrn nam fullpth )
   
2. 
   
3.   (vl-load-com)
   
4. 
   
5.   (defun AT:ListSelect ( title label height width multi lst / fn fo d item f )
   
6.     ;; List Select Dialog (Temp DCL list box selection, based on provided list)
   
7.     ;; title - list box title
   
8.     ;; label - label for list box
   
9.     ;; height - height of box
   
10.     ;; width - width of box
    
11.     ;; multi - selection method ["true": multiple, "false": single]
    
12.     ;; lst - list of strings to place in list box
    
13.     ;; Alan J. Thompson, 09.23.08 / 05.17.10 (rewrite)
    
14.     (setq fo (open (setq fn (vl-filename-mktemp "" "" ".dcl")) "w"))
    
15.     (foreach x (list (strcat "list_select : dialog { label = \"" title "\"; spacer;")
    
16.                      (strcat ": list_box { label = \"" label "\";" "key = \"lst\";")
    
17.                      (strcat "allow_accept = true; height = " (vl-princ-to-string height) ";")
    
18.                      (strcat "width = " (vl-princ-to-string width) ";")
    
19.                      (strcat "multiple_select = " multi "; } spacer; ok_cancel; }")
    
20.                )
    
21.       (write-line x fo)
    
22.     )
    
23.     (close fo)
    
24.     (new_dialog "list_select" (setq d (load_dialog fn)))
    
25.     (start_list "lst")
    
26.     (mapcar (function add_list) lst)
    
27.     (end_list)
    
28.     (setq item (set_tile "lst" "0"))
    
29.     (action_tile "lst" "(setq item $value)")
    
30.     (setq f (start_dialog))
    
31.     (unload_dialog d)
    
32.     (vl-file-delete fn)
    
33.     (if (= f 1)
    
34.       (mapcar '(lambda ( n ) (nth n lst)) (read (strcat "(" item ")")))
    
35.     )
    
36.   )
    
37. 
    
38.   (if (= 1 (getvar 'dwgtitled))
    
39.     (progn
    
40.       (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    
41.       (while (setq bl (tblnext "BLOCK" (null bl)))
    
42.         (setq bll (cons (cdr (assoc 2 bl)) bll))
    
43.       )
    
44.       (foreach bl bll
    
45.         (if (= (vla-get-isxref (vla-item (vla-get-blocks adoc) bl)) :vlax-true)
    
46.           (setq xrl (cons bl xrl))
    
47.         )
    
48.       )
    
49.       (foreach xr xrl
    
50.         (setq pthl (cons (vla-get-path (vla-item (vla-get-blocks adoc) xr)) pthl))
    
51.       )
    
52.       (if pthl
    
53.         (progn
    
54.           (while (null pth)
    
55.             (setq pth (car (AT:ListSelect "RENAME XREF" "Select Xref to rename:" 25 50 "false" pthl)))
    
56.           )
    
57.           (setq xrn (vl-filename-base pth))
    
58.           (setq nam (car xrl))
    
59.           (while (tblsearch "BLOCK" nam)
    
60.             (if (/= nam (car xrl))
    
61.               (alert "Specified filename already exist in DWG blocks database... Please specify different filename...")
    
62.             )
    
63.             (setq nam (lisped "TYPE NEW FILENAME WITHOUT EXTENSION"))
    
64.           )
    
65.           (if (= "." (substr pth 1 1))
    
66.             (setq fullpth (strcat (getvar 'dwgprefix) (substr pth 3)))
    
67.           )
    
68.           (if fullpth
    
69.             (vl-file-copy fullpth (strcat (vl-filename-directory fullpth) "\\" nam ".dwg"))
    
70.             (vl-file-copy pth (strcat (vl-filename-directory pth) "\\" nam ".dwg"))
    
71.           )
    
72.           (vl-cmdf "_.-XREF" "_P" xrn (if fullpth (strcat (vl-string-right-trim (strcat (vl-filename-base pth) ".dwg") pth) nam ".dwg") (strcat (vl-filename-directory pth) "\\" nam ".dwg")))
    
73.           (vl-cmdf "_.-RENAME" "_B" xrn nam)
    
74.           (if fullpth
    
75.             (vl-file-delete fullpth)
    
76.             (vl-file-delete pth)
    
77.           )
    
78.         )
    
79.         (prompt "\nDWG don't have XREF entities attached...")
    
80.       )
    
81.     )
    
82.     (alert "DWG isn't saved yet... Save DWG and restart routine again...")
    
83.   )
    
84.   (princ)
    
85. )
    

(defun c:xren ( / AT:ListSelect adoc bl bll xrl pthl pth xrn nam fullpth )<br /> <br />   (vl-load-com)<br /> <br />   (defun AT:ListSelect ( title label height width multi lst / fn fo d item f )<br />     ;; List Select Dialog (Temp DCL list box selection, based on provided list)<br />     ;; title - list box title<br />     ;; label - label for list box<br />     ;; height - height of box<br />     ;; width - width of box<br />     ;; multi - selection method ["true": multiple, "false": single]<br />     ;; lst - list of strings to place in list box<br />     ;; Alan J. Thompson, 09.23.08 / 05.17.10 (rewrite)<br />     (setq fo (open (setq fn (vl-filename-mktemp "" "" ".dcl")) "w"))<br />     (foreach x (list (strcat "list_select : dialog { label = \"" title "\"; spacer;")<br />                      (strcat ": list_box { label = \"" label "\";" "key = \"lst\";")<br />                      (strcat "allow_accept = true; height = " (vl-princ-to-string height) ";")<br />                      (strcat "width = " (vl-princ-to-string width) ";")<br />                      (strcat "multiple_select = " multi "; } spacer; ok_cancel; }")<br />                )<br />       (write-line x fo)<br />     )<br />     (close fo)<br />     (new_dialog "list_select" (setq d (load_dialog fn)))<br />     (start_list "lst")<br />     (mapcar (function add_list) lst)<br />     (end_list)<br />     (setq item (set_tile "lst" "0"))<br />     (action_tile "lst" "(setq item $value)")<br />     (setq f (start_dialog))<br />     (unload_dialog d)<br />     (vl-file-delete fn)<br />     (if (= f 1)<br />       (mapcar '(lambda ( n ) (nth n lst)) (read (strcat "(" item ")")))<br />     )<br />   )<br /> <br />   (if (= 1 (getvar 'dwgtitled))<br />     (progn<br />       (setq adoc (vla-get-activedocument (vlax-get-acad-object)))<br />       (while (setq bl (tblnext "BLOCK" (null bl)))<br />         (setq bll (cons (cdr (assoc 2 bl)) bll))<br />       )<br />       (foreach bl bll<br />         (if (= (vla-get-isxref (vla-item (vla-get-blocks adoc) bl)) :vlax-true)<br />           (setq xrl (cons bl xrl))<br />         )<br />       )<br />       (foreach xr xrl<br />         (setq pthl (cons (vla-get-path (vla-item (vla-get-blocks adoc) xr)) pthl))<br />       )<br />       (if pthl<br />         (progn<br />           (while (null pth)<br />             (setq pth (car (AT:ListSelect "RENAME XREF" "Select Xref to rename:" 25 50 "false" pthl)))<br />           )<br />           (setq xrn (vl-filename-base pth))<br />           (setq nam (car xrl))<br />           (while (tblsearch "BLOCK" nam)<br />             (if (/= nam (car xrl))<br />               (alert "Specified filename already exist in DWG blocks database... Please specify different filename...")<br />             )<br />             (setq nam (lisped "TYPE NEW FILENAME WITHOUT EXTENSION"))<br />           )<br />           (if (= "." (substr pth 1 1))<br />             (setq fullpth (strcat (getvar 'dwgprefix) (substr pth 3)))<br />           )<br />           (if fullpth<br />             (vl-file-copy fullpth (strcat (vl-filename-directory fullpth) "\\" nam ".dwg"))<br />             (vl-file-copy pth (strcat (vl-filename-directory pth) "\\" nam ".dwg"))<br />           )<br />           (vl-cmdf "_.-XREF" "_P" xrn (if fullpth (strcat (vl-string-right-trim (strcat (vl-filename-base pth) ".dwg") pth) nam ".dwg") (strcat (vl-filename-directory pth) "\\" nam ".dwg")))<br />           (vl-cmdf "_.-RENAME" "_B" xrn nam)<br />           (if fullpth<br />             (vl-file-delete fullpth)<br />             (vl-file-delete pth)<br />           )<br />         )<br />         (prompt "\nDWG don't have XREF entities attached...")<br />       )<br />     )<br />     (alert "DWG isn't saved yet... Save DWG and restart routine again...")<br />   )<br />   (princ)<br /> )<br />

sicky111

沙发支持。