[原创]：一个递增复制文字和属性块的程序

gysjy

最初由 userzhluserzhl  
发布
[B]如果可以再定义一下拷贝的起始点就更好了 [/B]

最初由 xotoo 发布
[B]楼主，能不能再修改一下，可以确定起始点——比如选择文字后，程序给出一个确定开始点的位置，而不是和现在一样，点击文字后程序立刻确认点击部位是开始点；可不可以修改程序变成——我们可以手动选择这个开始点 [/B]

将主程序修改如下：
[PHP](defun c:cptxt( / asc e1 e2 en en1 k l loop p p1 p2 sn sn1 st st1 st2)
  (command "undo" "g")
  (princ "\n欢迎使用文字或属性块连续增量拷贝程序! GYSJY  2008.12.16")
  (if (setq sn (entsel "\n点取物体:"))
    (progn
      (setq p1 (getpoint "\n基点:" ) p2 t sn (car sn) loop t)
      (if (or (= "TEXT" (to 0))(and p2 (to 66)(= "INSERT" (to 0))))
        (progn                                                
          (tqwz)
          (tqtxt)
          (setq l (1+ l ))
          (while p2
            (setq p2 (getpoint "\n下一点:" p1))
            (command "copy" sn "" p1 p2)   
            (setq sn (entlast) p1 p2 en (entget sn))
            (tqwz)
            (setq asc (ascii st))
            (if p2
              (if (and (= (strlen st) 1)
                    (or (and (> asc 64) (< asc 90))
                        (and (> asc 96) (< asc 122))
                    )
                  );判断字符串是否是单个字母
                (setq k (if (or (= asc 78)(= asc 72))(+ asc 2)(1+ asc));排除字母I,O
                      st (chr k)
                ) ;如果字符串是单个字母，则按字母顺序增长              
                (setq st2 (substr st l) st2 (tost2)
                      st (strcat st1 st2)  
                ) ;按数字增长
              )
            )
            (if (= "TEXT" (to 0))
              (progn
                (setq e1 (subst (cons 1 st) (assoc 1 en) en))
                (entmod e1)
              );修改文字
              (if (or loop p)
                (progn
                  (setq e1 (entget (entnext (cdr (car en)))))
                  (setq e1 (subst (cons 1 st) (assoc 1 e1) e1))
                  (entmod e1)(entmod en)
                )
                (progn
                  (setq  sn1(entnext sn) en1 (entget sn1)
                     e1 (entget (entnext (cdr (car en1))))
                     e2 (subst (cons 1 st) (assoc 1 e1) e1)
                  )
                  (entmod e2)(entmod en1)(entmod en)
                )
              );修改属性
            )
            (princ st)
          )
        )
        (princ "\n   ***你所点取的图元不是属性块或文字!本程序只拷贝带属性的块或文字。***")
      )
        )
  )
  (command "undo" "e")
  (princ)
)
[/PHP]

xotoo

非常感谢楼主及时修改程序，非常好用

另外我再厚着脸皮提一个建议，希望楼主能够看到……

能不能在楼上现有功能的基础上再增加一个功能——可以人为控制一次增量复制的数量——简单描述如下：

比如一个数字001，增量复制的时候，我先点选001这个数字，然后定位复制点，然后选择复制到的定位点——这个时候可不可以增加——以这个复制距离和复制方向为标准，选择需要复制多少个（每一个都是相对前一个的增量复制）

简单举例——有一个表格，纵向和横向分别有10行，最左上角的表格框中是001这个数字，我运行程序后点选001这个数字，然后在第一个表格框中点选一个复制定位点，然后纵向到第二行表格中找到和第一个表格相同的定位点（所谓相同的定位点就是——比如同是单个表格框的左下角的位置）进行第一个增量复制（比如增量复制为1），那么这个时候复制完的数值为002——在这里增加一个开关选项，一是可以继续和现有的复制模式一样，继续选择定位点进行下面的复制（这个设为默认模式），另外增加一个复制XX个的选项——如果选择了这个选项，那么程序就以第一个表格的定位点为基准定位点（比如单个表格框的左下角），以从第一个表格复制到第二个表格的方向为基准方向，以从第一个表格复制到第二个表格的距离（定位点与定位点之间的距离）为基准距离，同时复制XX个出来，每一个相比前一个都增量为1（这个可以设为选择选项）

非常希翼楼主可以看到这个小小的帖子并且能想出解决方案！谢谢！

gysjy

最初由 xotoo 发布
[B]非常感谢楼主及时修改程序，非常好用

……

能不能在楼上现有功能的基础上再增加一个功能——可以人为控制一次增量复制的数量……
[/B]

这个构想很好。现将主程序修改如下，并增添子程序chtxt，一并发在下面：
[PHP] (defun c:cptxt( / ang dis en l loop n p1 p2 sn st)
  (command "undo" "g")
  (princ "\n欢迎使用文字或属性块连续增量拷贝程序! GYSJY  2009.3.9更新")
  (if (setq sn (entsel "\n点取物体:"))
    (progn
      (setq p1 (getpoint "\n基点:" )  p2 t sn (car sn) loop t)
      (if (or (= "TEXT" (to 0))(and p2 (to 66)(= "INSERT" (to 0))))
        (progn                                                
          (tqwz)
          (tqtxt)
          (setq l (1+ l ))
          (while p2
            (initget "A")
            (setq p2 (getpoint "\nA单行阵列/下一点:" p1))
            (if (= p2 "A")
              (progn
                (setq p2 (getpoint "\n第二点:" p1)
                      dis (distance p1 p2) ang (angle p1 p2)
                      n (getint "\n拷贝个数<2>:")
                )
                (if (= n nil)(setq n 2))              
                (repeat (1- n)  
                  (command "copy" sn "" p1 p2)
                  (setq sn (entlast) p1 p2 en (entget sn)
                        p2 (polar p1 ang dis)
                  )
                  (tqwz)(chtxt)
                )
                ;(setq p2 nil)
              )
            )
            (command "copy" sn "" p1 p2)   
            (setq sn (entlast) p1 p2 en (entget sn))
            (tqwz)
            (chtxt)
            (princ st)
          )
        )
        (princ "\n   ***你所点取的图元不是属性块或文字!本程序只拷贝带属性的块或文字。***")
      )
        )
  )
  (command "undo" "e")
  (princ)
)
(defun chtxt()
            (setq asc (ascii st))
            (if p2
              (if (and (= (strlen st) 1)
                    (or (and (> asc 64) (< asc 90))
                        (and (> asc 96) (< asc 122))
                    )
                  );判断字符串是否是单个字母
                (setq k (if (or (= asc 78)(= asc 72))(+ asc 2)(1+ asc));排除字母I,O
                      st (chr k)
                ) ;如果字符串是单个字母，则按字母顺序增长              
                (setq st2 (substr st l) st2 (tost2)
                      st (strcat st1 st2)  
                ) ;按数字增长
              )
            )
            (if (= "TEXT" (to 0))
              (progn
                (setq e1 (subst (cons 1 st) (assoc 1 en) en))
                (entmod e1)
              );修改文字
              (if (or loop p)
                (progn
                  (setq e1 (entget (entnext (cdr (car en)))))
                  (setq e1 (subst (cons 1 st) (assoc 1 e1) e1))
                  (entmod e1)(entmod en)
                )
                (progn
                  (setq  sn1(entnext sn) en1 (entget sn1)
                     e1 (entget (entnext (cdr (car en1))))
                     e2 (subst (cons 1 st) (assoc 1 e1) e1)
                  )
                  (entmod e2)(entmod en1)(entmod en)
                )
              );修改属性
            )
)     [/PHP]

gysjy

如图。

xotoo

谢谢楼主及时修改程序，以后我终于不用再为排序号犯难了，超级感谢——我暂时也想不起来别的无理的要求了，谢谢！

az98hxq

非常不错的程序，关键还是源代码的，太感谢楼主了！

userzhluserzhl

如果是属性块的话，无法定义“拷贝的起始点”。

gysjy

最初由 userzhluserzhl 发布
[B]如果是属性块的话，无法定义“拷贝的起始点”。 [/B]

不太明白，为什么无法定义拷贝的起始点？事实上是可以定义的。

xuyu

楼主是否可以做到这样呢，在做图纸的编号时复制，增量复制时只递增前面的数字，如01/12复制时变成02/12，03*12，04/12等，谢谢楼主的程序

userzhluserzhl

如果能够框选多个对象的话，那就完美了。

gysjy

最初由 xuyu 发布
[B]楼主是否可以做到这样呢，在做图纸的编号时复制，增量复制时只递增前面的数字，如01/12复制时变成02/12，03*12，04/12等，谢谢楼主的程序 [/B]

将主程序改为：
[PHP](defun c:cptxt( / ang dis en l loop n p1 p2 sn st)
  (setq *error* nil)
  (command "undo" "g")
  (princ "\n欢迎使用文字或属性块连续增量拷贝程序! GYSJY  2008.12.16")
  (if (setq sn (entsel "\n点取物体:"))
    (progn
      (setq p1 (getpoint "\n基点:" )  p2 t sn (car sn) loop t)
      (if (or (= "TEXT" (to 0))(and p2 (to 66)(= "INSERT" (to 0))))
        (progn                                                
          (tqwz)(setq st (revstr st))
          (tqtxt)
          (setq l (1+ l ))
          (while p2
            (initget "A")
            (setq p2 (getpoint "\nA单行阵列/下一点:" p1))
            (if (= p2 "A")
              (progn
                (setq p2 (getpoint "\n第二点:" p1)
                      dis (distance p1 p2) ang (angle p1 p2)
                      n (getint "\n拷贝个数<2>:")
                )
                (if (= n nil)(setq n 2))              
                (repeat (1- n)  
                  (command "copy" sn "" p1 p2)
                  (setq sn (entlast) p1 p2 en (entget sn)
                        p2 (polar p1 ang dis)
                  )
                  (tqwz)(setq st (revstr st))(chtxt)
                )
                ;(setq p2 nil)
              )
            )
            (command "copy" sn "" p1 p2)   
            (setq sn (entlast) p1 p2 en (entget sn))
            (tqwz)(setq st (revstr st))
            (chtxt)
            (princ st)
          )
        )
        (princ "\n   ***你所点取的图元不是属性块或文字!本程序只拷贝带属性的块或文字。***")
      )
        )
  )
  (command "undo" "e")
  (princ)
)
(defun chtxt()
            (setq asc (ascii st))
            (if p2
              (if (and (= (strlen st) 1)
                    (or (and (> asc 64) (< asc 90))
                        (and (> asc 96) (< asc 122))
                    )
                  );判断字符串是否是单个字母
                (setq k (if (or (= asc 78)(= asc 72))(+ asc 2)(1+ asc));排除字母I,O
                      st (chr k)
                ) ;如果字符串是单个字母，则按字母顺序增长              
                (setq st2 (substr st l) st2 (revstr st2) st2 (tost2) st2 (revstr st2)
                      st (strcat st1 st2)
                ) ;按数字增长
              )
            );(princ st)(getstring)
            (setq st (revstr st))
            (if (= "TEXT" (to 0))
              (progn
                (setq e1 (subst (cons 1 st) (assoc 1 en) en))
                (entmod e1)
              );修改文字
              (if (or loop p)
                (progn
                  (setq e1 (entget (entnext (cdr (car en)))))
                  (setq e1 (subst (cons 1 st) (assoc 1 e1) e1))
                  (entmod e1)(entmod en)
                )
                (progn
                  (setq  sn1(entnext sn) en1 (entget sn1)
                     e1 (entget (entnext (cdr (car en1))))
                     e2 (subst (cons 1 st) (assoc 1 e1) e1)
                  )
                  (entmod e2)(entmod en1)(entmod en)
                )
              );修改属性
            )
)     


(defun revstr(st / l n st0 st1 st2);;将字符串倒序
  (setq st1 "" st2 st l (strlen st) n l)
  (repeat l
    (setq st0 (substr st2 n) st2 (substr st 1 (1- n))
          st1 (strcat st1 st0) n (strlen st2)
    )
  )st1
)
[/PHP]

gysjy

最初由 xuyu 发布
[B]楼主是否可以做到这样呢，在做图纸的编号时复制，增量复制时只递增前面的数字，如01/12复制时变成02/12，03*12，04/12等 [/B]

如图所示：

userzhluserzhl

但是,如果这样的话,拷贝1A-D5就成了2A-D5，而不是1A-D6了。

lifuding

我用的是2009 出现下面的提示
命令: cptxt

欢迎使用文字或属性块连续增量拷贝程序! GYSJY  2009.3.9更新
点取物体:
基点:error: no function definition: TO

zhuxiaoming

看的我眼花缭乱,高手如云啊!非常感谢!