etom999 发表于 2008-3-11 07:34:00

[求助]属性块的增量复制

本帖最后由 作者 于 2008-3-18 7:06:00 编辑

文件添加

ZZXXQQ 发表于 2008-3-24 16:06:00

本帖最后由 作者 于 2008-3-28 20:41:34 编辑

再试试。


;拷贝属性加1&设定所有属性可编辑明经 ZZXXQQ 2008.3.18 2008.3.27
(DEFUN C:ADD1 ()
(SETVAR "CMDECHO" 0)
(IF (AND (SETQ S1 (CAR (ENTSEL "\nSelect Block with Attrib 选择带属性图块 :")))
          (SETQ ENT (ENTGET S1))
    (= (CDR (ASSOC 0 ENT)) "INSERT")
    (= (CDR (ASSOC 66 ENT)) 1)
) (PROGN
(COMMAND ".UNDO" "BE")
(SETQ PT0 (CDR (ASSOC 10 ENT)) N nil M nil)
(WHILE (SETQ PT1 (GETPOINT PT0 "\nInsert Point 插入点 :"))
   (COMMAND ".COPY" S1 "" PT0 PT1)
   (SETQ ENT1 (ENTGET(ENTLAST)) ENT2 ENT1)
   (WHILE (= (CDR(ASSOC 0 (SETQ ENT2 (ENTGET(ENTNEXT(CDR(ASSOC -1 ENT2))))))) "ATTRIB")
    (IF (= (CDR(ASSOC 2 ENT2)) "KKS_CODE") (PROGN
   (SETQ TXTF (CDR(ASSOC 1 ENT2)) TXTA "" I 1 SL (STRLEN TXTF))
   (WHILE (AND (> (SETQ TA (SUBSTR TXTF I 1)) "9") (< TA "0") (< I SL))
      (SETQ TXTA (STRCAT TXTA TA) I (1+ I))
   )
   (IF (<= I SL) (PROGN
      (SETQ N (1+ (IF N N (ATOI (SUBSTR TXTF I))))
               TXTF (STRCAT TA (IF (< N 10) "00" (IF (< N 100) "0" "")) (ITOA N))
               ENT1 (SUBST (CONS 1 TXTF) (ASSOC 1 ENT2) ENT2))
      (ENTMOD ENT2)
      (ENTMOD ENT1)
      (ENTUPD (ENTLAST))
   ))
    ))
    (IF (= (CDR(ASSOC 2 ENT2)) "SNA") (PROGN
   (SETQ TXTF (CDR(ASSOC 1 ENT2)) TXTA "" I 1 SL (STRLEN TXTF))
   (WHILE (AND (> (SETQ TA (SUBSTR TXTF I 1)) "9") (< TA "0") (< I SL))
      (SETQ TXTA (STRCAT TXTA TA) I (1+ I))
   )
   (IF (<= I SL) (PROGN
      (SETQ M (1+ (IF M M (ATOI (SUBSTR TXTF I))))
               TXTF (STRCAT (SUBSTR TXTF 1 2) (IF (< M 10) "00" (IF (< M 100) "0" "")) (ITOA M))
               ENT1 (SUBST (CONS 1 TXTF) (ASSOC 1 ENT2) ENT2))
      (ENTMOD ENT2)
      (ENTMOD ENT1)
      (ENTUPD (ENTLAST))
   ))
    ))
    (IF (ASSOC 60 ENT2) (PROGN
   (SETQ ENT2 (SUBST '(60 . 0) (ASSOC 60 ENT2) ENT2))
   (ENTMOD ENT2)
   (ENTMOD ENT1)
   (ENTUPD (ENTLAST))
    ))
   )
)
(COMMAND ".UNDO" "E")
))
(SETVAR "CMDECHO" 1)
(PRINC)
)

xj6019 发表于 2019-12-11 22:48:13

本帖最后由 xj6019 于 2019-12-11 22:49 编辑

老帖子顶一下 很实用的功能 电脑运行不了啊   问问cad2015运行35楼的代码为什么不能递增复制呀谁帮忙看看，高版本不支持吗？
代码是35楼抄来的 浏览方便，麻烦懂的给看看呗。

(DEFUN C:ADD1 ()
(SETVAR "CMDECHO" 0)
(IF (AND (SETQ S1 (CAR (ENTSEL "\nSelect Block with Attrib 选择带属性图块 :")))
          (SETQ ENT (ENTGET S1))
    (= (CDR (ASSOC 0 ENT)) "INSERT")
    (= (CDR (ASSOC 66 ENT)) 1)
) (PROGN
(COMMAND ".UNDO" "BE")
(SETQ PT0 (CDR (ASSOC 10 ENT)) N nil M nil)
(WHILE (SETQ PT1 (GETPOINT PT0 "\nInsert Point 插入点 :"))
   (COMMAND ".COPY" S1 "" PT0 PT1)
   (SETQ ENT1 (ENTGET(ENTLAST)) ENT2 ENT1)
   (WHILE (= (CDR(ASSOC 0 (SETQ ENT2 (ENTGET(ENTNEXT(CDR(ASSOC -1 ENT2))))))) "ATTRIB")
    (IF (= (CDR(ASSOC 2 ENT2)) "KKS_CODE") (PROGN
   (SETQ TXTF (CDR(ASSOC 1 ENT2)) TXTA "" I 1 SL (STRLEN TXTF))
   (WHILE (AND (> (SETQ TA (SUBSTR TXTF I 1)) "9") (< TA "0") (< I SL))
      (SETQ TXTA (STRCAT TXTA TA) I (1+ I))
   )
   (IF (<= I SL) (PROGN
      (SETQ N (1+ (IF N N (ATOI (SUBSTR TXTF I))))
               TXTF (STRCAT TA (IF (< N 10) "00" (IF (< N 100) "0" "")) (ITOA N))
               ENT1 (SUBST (CONS 1 TXTF) (ASSOC 1 ENT2) ENT2))
      (ENTMOD ENT2)
      (ENTMOD ENT1)
      (ENTUPD (ENTLAST))
   ))
    ))
    (IF (= (CDR(ASSOC 2 ENT2)) "SNA") (PROGN
   (SETQ TXTF (CDR(ASSOC 1 ENT2)) TXTA "" I 1 SL (STRLEN TXTF))
   (WHILE (AND (> (SETQ TA (SUBSTR TXTF I 1)) "9") (< TA "0") (< I SL))
      (SETQ TXTA (STRCAT TXTA TA) I (1+ I))
   )
   (IF (<= I SL) (PROGN
      (SETQ M (1+ (IF M M (ATOI (SUBSTR TXTF I))))
               TXTF (STRCAT (SUBSTR TXTF 1 2) (IF (< M 10) "00" (IF (< M 100) "0" "")) (ITOA M))
               ENT1 (SUBST (CONS 1 TXTF) (ASSOC 1 ENT2) ENT2))
      (ENTMOD ENT2)
      (ENTMOD ENT1)
      (ENTUPD (ENTLAST))
   ))
    ))
    (IF (ASSOC 60 ENT2) (PROGN
   (SETQ ENT2 (SUBST '(60 . 0) (ASSOC 60 ENT2) ENT2))
   (ENTMOD ENT2)
   (ENTMOD ENT1)
   (ENTUPD (ENTLAST))
    ))
   )
)
(COMMAND ".UNDO" "E")
))
(SETVAR "CMDECHO" 1)
(PRINC)
)

xj6019 发表于 2019-12-12 18:40:00

ZZXXQQ 发表于 2008-3-24 16:06
再试试。



冒昧打扰一下，您35楼的这个代码为什么高版本cad不能运行呀，很想用一下，需要一个属性块可以递增复制的程序，谢谢了！

etom999 发表于 2008-3-14 07:22:00

ZZXXQQ大侠,能解决一下？

ZZXXQQ 发表于 2008-3-14 16:49:00

<p>为调试程序请给个样图。</p>

etom999 发表于 2008-3-17 06:55:00

本帖最后由 作者 于 2008-3-17 6:56:51 编辑 <br /><br /> 块ABB-CL-SG中，<br/>SNA,XR_FUNCTION是要复制增加的属性<a href="file:///I:/ABB-CL-SG.rar">ABB-CL-SG.rar</a>

ZZXXQQ 发表于 2008-3-17 07:58:00

无法下载!

etom999 发表于 2008-3-18 07:04:00

[下载]

添加文件<a href="file:///F:/ED2003/LI/DINZCY/ABB-CL-SG.DWG"></a>

etom999 发表于 2008-3-18 07:31:00

DWG文件怎么上传

ZZXXQQ 发表于 2008-3-18 08:20:00

<p>可以直接上传。如文件太大，也可以压缩后上传。先点[浏览]钮选择文件后点[上传]钮，上传完毕后再点[回复]。</p>

etom999 发表于 2008-3-18 11:58:00

我就是上传不上...

etom999 发表于 2008-3-18 12:01:00

回复：（ZZXXQQ）可以直接上传。如文件太大，也可以压...

How about<br/>
页: [1] 2 3 4 5 6 7
查看完整版本: [求助]属性块的增量复制