根据文件名改属性块（求简化）

spp_wall

;根据文件名改属性块 文件名格式： 图号空格图名空格总页码空格
(DEFUN CHATTRIB (OLDATT NEWATT)
(IF (AND ;(PRINC "\nSelect Block with attribute 选择带属性图块 :")

                  ;(SETQ SS (SSGET '((0 . "INSERT") (66 . 1))))
                  
        (SETQ SS (SSGET "X" '((0 . "INSERT") (66 . 1)(2 . "KX-目录属性块"))));只选择"KX-目录属性块"
                  )
                  (PROGN
  (SETQ I -1)
  (REPEAT (SSLENGTH SS)
   (SETQ ENT (ENTGET (SSNAME SS (SETQ I (1+ I))))
         ENT1 ENT)
   (WHILE (= (CDR (ASSOC 0 (SETQ ENT1 (ENTGET (ENTNEXT (CDR (ASSOC -1 ENT1))))))) "ATTRIB")
    (IF (= (CDR (ASSOC 1 ENT1)) OLDATT) (PROGN
  (SETQ ENT1 (SUBST (CONS 1 NEWATT) (ASSOC 1 ENT1) ENT1))
  (ENTMOD ENT1)
  (ENTMOD ENT)
))
   )
  )
))
(PRINC)
)

(defun strsplit(str splits / i a b)
  (while(<""str)
    (if(vl-remove'nil(mapcar'(lambda(x)(vl-string-search x str))splits))
      (setq i(car(vl-sort(vl-remove'nil(mapcar'(lambda(x)(if(setq l(vl-string-search x str))(cons l x)))splits))
       '(lambda(s1 s2)(<(car s1)(car s2)))))
      a(cons(substr str 1(car i))a)b(cons(cdr i)b)
      str(substr str(+(car i)(strlen(cdr i))1)))
      (setq a(cons str a)b(cons "" b)str"")))
  (list(reverse a)(reverse b)))

(DEFUN C:gtm ()
(SETQ OATT (GETSTRING "\n原始图名:"));这里能不能改成点选属性块中的属性而不是输入

        (vl-load-com)
(setq  kx-tm (cadr(car(strsplit(getvar "dwgname")'(" ")))))

(CHATTRIB OATT kx-tm )
  (PRINC)
)

(DEFUN C:gth ()
(SETQ OATT (GETSTRING "\n原始图号:"));这里能不能改成点选属性块中的属性而不是输入

        (vl-load-com)
(setq  kx-th (car(car(strsplit(getvar "dwgname")'(" ")))))

(CHATTRIB OATT kx-th )
  (PRINC)
)

(DEFUN C:gzym ()
(SETQ OATT (GETSTRING "\n原始总页码:"));这里能不能改成点选属性块中的属性而不是输入

        (vl-load-com)
(setq  kx-zym (caddr(car(strsplit(getvar "dwgname")'(" ")))))

(CHATTRIB OATT kx-zym )
  (PRINC)
)

想省去输入原始属性块中值，改成点选属性块！求大家出手简化！

vectra

1. (vl-load-com)
   
2. 
   
3. (defun strsplit        (string delimited / pos lst)
   
4.   (while (setq pos (vl-string-search delimited string))
   
5.     (setq lst         (cons (substr string 1 pos) lst)
   
6.           string (substr string (+ pos 1 (strlen delimited)))
   
7.     )
   
8.   )
   
9.   (reverse (cons string lst))
   
10. )
    
11. 
    
12. (defun parse-filename ()
    
13.   (strsplit (vl-string-trim " \r\t\n" (vl-filename-base (getvar "DWGNAME"))) " ")
    
14. )
    
15. ;; ("MM-01" "平面图" "5")
    
16. 
    
17. (defun c:tt (/ block i kx ss tag)
    
18.   (setq kx (parse-filename))
    
19. 
    
20.   (if (setq ss (ssget "X" '((0 . "INSERT") (66 . 1) (2 . "KX-目录属性块"))))
    
21.     (progn
    
22.       (setq i -1)
    
23.       (repeat (sslength ss)
    
24.         (setq block (vlax-ename->vla-object (ssname ss (setq i (1+ i)))))
    
25. 
    
26.         (foreach att (vlax-safearray->list
    
27.                        (vlax-variant-value (vla-getattributes block))
    
28.                      )
    
29.           (setq tag (vla-get-tagstring att))
    
30.           (cond
    
31.             ((= "总页码" tag)
    
32.              (vla-put-textstring att (nth 2 kx))
    
33.             )
    
34.             ((= "图号" tag)
    
35.              (vla-put-textstring att (nth 0 kx))
    
36.             )
    
37.             ((= "图名" tag)
    
38.              (vla-put-textstring att (nth 1 kx))
    
39.             )
    
40.           )
    
41.         )
    
42.       )
    
43.     )
    
44.   )
    
45.   (princ)
    
46. )

(vl-load-com)<br /> <br /> (defun strsplit        (string delimited / pos lst)<br />   (while (setq pos (vl-string-search delimited string))<br />     (setq lst         (cons (substr string 1 pos) lst)<br />           string (substr string (+ pos 1 (strlen delimited)))<br />     )<br />   )<br />   (reverse (cons string lst))<br /> )<br /> <br /> (defun parse-filename ()<br />   (strsplit (vl-string-trim " \r\t\n" (vl-filename-base (getvar "DWGNAME"))) " ")<br /> )<br /> ;; ("MM-01" "平面图" "5")<br /> <br /> (defun c:tt (/ block i kx ss tag)<br />   (setq kx (parse-filename))<br /> <br />   (if (setq ss (ssget "X" '((0 . "INSERT") (66 . 1) (2 . "KX-目录属性块"))))<br />     (progn<br />       (setq i -1)<br />       (repeat (sslength ss)<br />         (setq block (vlax-ename->vla-object (ssname ss (setq i (1+ i)))))<br /> <br />         (foreach att (vlax-safearray->list<br />                        (vlax-variant-value (vla-getattributes block))<br />                      )<br />           (setq tag (vla-get-tagstring att))<br />           (cond<br />             ((= "总页码" tag)<br />              (vla-put-textstring att (nth 2 kx))<br />             )<br />             ((= "图号" tag)<br />              (vla-put-textstring att (nth 0 kx))<br />             )<br />             ((= "图名" tag)<br />              (vla-put-textstring att (nth 1 kx))<br />             )<br />           )<br />         )<br />       )<br />     )<br />   )<br />   (princ)<br /> )

spp_wall

vectra 发表于 2014-10-29 11:51

比我要求的还快！！！谢谢！

hooboxu

这是什么意思啊。没看懂。有图吗？

spp_wall

hooboxu 发表于 2014-10-29 12:39
这是什么意思啊。没看懂。有图吗？

上面不是有图么

qianwh1210

这个好啊,叼炸天,学习了

spp_wall

vectra 发表于 2014-10-29 11:51

再请教下
(ssget "X" '((0 . "INSERT")(66 . 1) ));可以选择所有的属性块
如果还要添加其他特定的属性块 应该怎么改呢！

hooboxu

没看到有图片啊

qianwh1210

这个吊炸天啊

gzsod

大佬牛666  好用  CAD版图号名称分离程序