批量拆离影像

yangqingchao

1. 有时修影像已经删除，但没有拆离，再次插入的时候会提示出错，本程序可以批量拆离已删除影像。本人刚接触autolisp，请不要见笑！

复制代码

1. (prompt "本程序执行命令是: DetachIMG\n")
   
2. (defun c:DetachIMG ( / imageDict ss1 ss2 num lst newlst n blkName fileList)
   
3.   (setvar "cmdecho" 0)
   
4.   (setq ss1 (X:flists))
   
5.   (setq imageDict (dictsearch (namedobjdict) "ACAD_IMAGE_DICT"))
   
6.   (setq num (length imageDict))
   
7.   (setq lst (XD:ist:Nth++ imageDict 10 (- num 10)))
   
8.   (setq newlst (XD:IST:Group-n lst 2))
   
9.   (setq n (length newlst))
   
10.   (while (< 0 n)
    
11.     (setq blkName (cdr (car (nth (setq n (- n 1)) newlst))))
    
12.     (setq fullName (cdr (assoc 1 (entget (cdr (car (cdr (nth n newlst))))))))
    
13.     (setq fileName (strcat (vl-filename-base fullName) (vl-filename-extension fullName)))
    
14.     (if (= nil ss1)
    
15.       (progn
    
16.         (setq fileList (cons fileName fileList))
    
17.         (command "_image" "Detach" blkName)
    
18.         (princ (strcat filename "在文档中已删除，因此被拆离！\n"))
    
19.       )
    
20.       (progn
    
21.         (setq ss2 (vl-remove-if-not '(lambda (x) (= x fullName)) ss1))
    
22.         (if (= nil ss2)
    
23.           (progn
    
24.             (setq fileList (cons fileName fileList))
    
25.             (command "_image" "Detach" blkName)
    
26.             (princ (strcat filename "在文档中已删除，因此被拆离！\n"))
    
27.           )
    
28.         )
    
29.       )
    
30.     )
    
31.   )
    
32.   (vl-sort fileList '<)
    
33.   (if (/= nil fileList)
    
34.     (princ (strcat "共拆离" (itoa (length fileList)) "张影像！\n"))
    
35.    (princ "没有影像可以拆离！\n")
    
36.   )
    
37.   (princ)
    
38. )
    
39. (defun X:flists( / *fullName *fileName filelists)
    
40.   (setq ss (ssget "X" '((0 . "IMAGE"))));;;全选所有光栅对象
    
41.   (if (= nil ss);;;如果不存在
    
42.     (setq filelists nil);;;没有对象，则返回nil
    
43.     (progn
    
44.     (setq i (sslength ss))
    
45.       (while (< 0 i)
    
46.         (setq ee (ssname ss (setq i (1- i))))
    
47.         (setq vlaobj (vlax-ename->vla-object ee))
    
48.         (setq *fullName (vla-get-ImageFile vlaobj))
    
49.         ;(setq *fileName (strcat (vl-filename-base *fullName) (vl-filename-extension *fullName)))
    
50.         (setq filelists (cons *fullName filelists))
    
51.       )
    
52.     )   
    
53.   )
    
54.   (vl-sort filelists '<);;;返回排序列表
    
55. )
    
56. ;;;此函数来自晓东CAD
    
57. (defun XD:ist:Nth++ (l s n)
    
58.     (repeat (/ s 4) (setq l (cddddr l)))
    
59.     (repeat (rem s 4) (setq l (cdr l)))
    
60.     (setq s nil)
    
61.     (if (and l n)
    
62.         (cond ((>= n (length l)) l)
    
63.               ((< n (- (length l) n))
    
64.                (repeat (/ n 4)
    
65.                    (setq s (cons (cadddr l)
    
66.                                  (cons (caddr l) (cons (cadr l) (cons (car l) s)))
    
67.                            )
    
68.                          l (cddddr l)
    
69.                    )
    
70.                )
    
71.                (repeat (rem n 4)
    
72.                    (setq s (cons (car l) s)
    
73.                          l (cdr l)
    
74.                    )
    
75.                )
    
76.                (reverse s)
    
77.               )
    
78.               (t
    
79.                (setq l (reverse l)
    
80.                      s (- (length l) n)
    
81.                )
    
82.                (repeat (/ s 4) (setq l (cddddr l)))
    
83.                (repeat (rem s 4) (setq l (cdr l)))
    
84.                (reverse l)
    
85.               )
    
86.         )
    
87.         l
    
88.     )
    
89. )
    
90. ;;;此函数来自晓东CAD
    
91. (defun XD:IST:Group-n ( l n / a b )
    
92.     (while l
    
93.         (repeat n
    
94.             (setq a (cons (car l) a)
    
95.                   l (cdr l)
    
96.             )
    
97.         )
    
98.         (setq b (cons (reverse a) b)
    
99.               a nil
    
100.         )
     
101.     )
     
102.     (reverse b)
     
103. )

(prompt "本程序执行命令是: DetachIMG\n")<br /> (defun c:DetachIMG ( / imageDict ss1 ss2 num lst newlst n blkName fileList)<br />   (setvar "cmdecho" 0)<br />   (setq ss1 (X:flists))<br />   (setq imageDict (dictsearch (namedobjdict) "ACAD_IMAGE_DICT"))<br />   (setq num (length imageDict))<br />   (setq lst (XD:<img src="static/image/smiley/default/sweat.gif" smilieid="10" border="0" alt="" />ist:Nth++ imageDict 10 (- num 10)))<br />   (setq newlst (XD:<img src="static/image/smiley/default/sweat.gif" smilieid="10" border="0" alt="" />IST:Group-n lst 2))<br />   (setq n (length newlst))<br />   (while (< 0 n)<br />     (setq blkName (cdr (car (nth (setq n (- n 1)) newlst))))<br />     (setq fullName (cdr (assoc 1 (entget (cdr (car (cdr (nth n newlst))))))))<br />     (setq fileName (strcat (vl-filename-base fullName) (vl-filename-extension fullName)))<br />     (if (= nil ss1)<br />       (progn<br />         (setq fileList (cons fileName fileList))<br />         (command "_image" "Detach" blkName)<br />         (princ (strcat filename "在文档中已删除，因此被拆离！\n"))<br />       )<br />       (progn<br />         (setq ss2 (vl-remove-if-not '(lambda (x) (= x fullName)) ss1))<br />         (if (= nil ss2)<br />           (progn<br />             (setq fileList (cons fileName fileList))<br />             (command "_image" "Detach" blkName)<br />             (princ (strcat filename "在文档中已删除，因此被拆离！\n"))<br />           )<br />         )<br />       )<br />     )<br />   )<br />   (vl-sort fileList '<)<br />   (if (/= nil fileList)<br />     (princ (strcat "共拆离" (itoa (length fileList)) "张影像！\n"))<br />    (princ "没有影像可以拆离！\n")<br />   )<br />   (princ)<br /> )<br /> (defun X:flists( / *fullName *fileName filelists)<br />   (setq ss (ssget "X" '((0 . "IMAGE"))));;;全选所有光栅对象<br />   (if (= nil ss);;;如果不存在<br />     (setq filelists nil);;;没有对象，则返回nil<br />     (progn<br />     (setq i (sslength ss))<br />       (while (< 0 i)<br />         (setq ee (ssname ss (setq i (1- i))))<br />         (setq vlaobj (vlax-ename->vla-object ee))<br />         (setq *fullName (vla-get-ImageFile vlaobj))<br />         ;(setq *fileName (strcat (vl-filename-base *fullName) (vl-filename-extension *fullName)))<br />         (setq filelists (cons *fullName filelists))<br />       )<br />     )    <br />   )<br />   (vl-sort filelists '<);;;返回排序列表<br /> )<br /> ;;;此函数来自晓东CAD<br /> (defun XD:<img src="static/image/smiley/default/sweat.gif" smilieid="10" border="0" alt="" />ist:Nth++ (l s n)<br />     (repeat (/ s 4) (setq l (cddddr l)))<br />     (repeat (rem s 4) (setq l (cdr l)))<br />     (setq s nil)<br />     (if (and l n)<br />         (cond ((>= n (length l)) l)<br />               ((< n (- (length l) n))<br />                (repeat (/ n 4)<br />                    (setq s (cons (cadddr l)<br />                                  (cons (caddr l) (cons (cadr l) (cons (car l) s)))<br />                            )<br />                          l (cddddr l)<br />                    )<br />                )<br />                (repeat (rem n 4)<br />                    (setq s (cons (car l) s)<br />                          l (cdr l)<br />                    )<br />                )<br />                (reverse s)<br />               )<br />               (t<br />                (setq l (reverse l)<br />                      s (- (length l) n)<br />                )<br />                (repeat (/ s 4) (setq l (cddddr l)))<br />                (repeat (rem s 4) (setq l (cdr l)))<br />                (reverse l)<br />               )<br />         )<br />         l<br />     )<br /> )<br /> ;;;此函数来自晓东CAD<br /> (defun XD:<img src="static/image/smiley/default/sweat.gif" smilieid="10" border="0" alt="" />IST:Group-n ( l n / a b )<br />     (while l<br />         (repeat n<br />             (setq a (cons (car l) a)<br />                   l (cdr l)<br />             )<br />         )<br />         (setq b (cons (reverse a) b)<br />               a nil<br />         )<br />     )<br />     (reverse b)<br /> )

paulpipi

谢谢分享

flowerson

不用command 用vlisp 怎样写呢？