找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 3385|回复: 22

[每日一码] 局部复制文字

[复制链接]

已领礼包: 593个

财富等级: 财运亨通

发表于 2013-9-8 16:32:16 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

您需要 登录 才可以下载或查看,没有账号?立即注册

×
在一个Text复制指定范围文字
  1. (defun XD::String:SingleChr (str / lst tf ll)
  2.   (setq lst (vl-string->list str))
  3.   (while lst
  4.     (cond
  5.       ((> (car lst) 127) ;_中文
  6.        (if tf
  7.      (setq ll
  8.         (cons
  9.           (strcat "%%u"
  10.               (vl-list->string (list (car lst) (cadr lst)))
  11.               "%%u"
  12.           )
  13.           ll
  14.         )
  15.      )
  16.      (setq ll
  17.         (cons (vl-list->string (list (car lst) (cadr lst))) ll)
  18.      )
  19.        )
  20.        (setq lst (cddr lst))
  21.       )
  22.       ((= (car lst) (cadr lst) (caddr lst) 37) ;_%
  23.        (if tf
  24.      (setq ll
  25.         (cons (strcat "%%u" (vl-list->string '(37 37 37)) "%%u")
  26.               ll
  27.         )
  28.      )
  29.      (setq ll (cons (vl-list->string '(37 37 37)) ll))
  30.        )
  31.        (setq lst (cdddr lst))
  32.       )
  33.       ((and (= (car lst) (cadr lst) 37)
  34.         (vl-position (caddr lst) '(80 112 67 99 68 100 79 111))
  35.        ) ;_ %%c %%p %%d %%p %%o
  36.        (if tf
  37.      (setq ll
  38.         (cons (strcat "%%u"
  39.                   (vl-list->string (list 37 37 (caddr lst)))
  40.                   "%%u"
  41.               )
  42.               ll
  43.         )
  44.      )
  45.      (setq
  46.        ll (cons (vl-list->string (list 37 37 (caddr lst))) ll)
  47.      )
  48.        )
  49.        (setq lst (cdddr lst))
  50.       )
  51.       ((and (= (car lst) (cadr lst) 37)
  52.         (vl-position (caddr lst) '(85 117))
  53.        ) ;_%%U
  54.        (if tf
  55.      (setq tf nil)
  56.      (setq tf t)
  57.        )
  58.        (setq lst (cdddr lst))
  59.       )
  60.       (t
  61.        (if tf
  62.      (setq ll (cons    (strcat    "%%u"
  63.                 (vl-list->string (list (car lst)))
  64.                 "%%u"
  65.             )
  66.             ll
  67.           )
  68.      )
  69.      (setq ll (cons (vl-list->string (list (car lst))) ll))
  70.        )
  71.        (setq lst (cdr lst))
  72.       )
  73.     )
  74.   )
  75.   (reverse ll)
  76. )
  77. ;;两点或者一点处的文字
  78. (defun XD::String:Between (el    p1   p2      /    gettl     el   h       sty
  79.                an    str  nstr nnstr        ll     l    zl   inspt
  80.                p    pl   pstr i    i1   i2
  81.               )
  82.   ;;获取文字的长度,仅需要基本的表
  83.   (defun gettl (l / box)
  84.     (setq box (textbox l))
  85.     (car (mapcar '- (cadr box) (car box)))
  86.   )
  87.   (setq    h     (assoc 40 el) ;_高度
  88.     sty   (assoc 7 el) ;_字体
  89.     an    (cdr (assoc 50 el)) ;_角度
  90.     str   (cdr (assoc 1 el)) ;_textstring
  91.     nstr  (xd::string:singlechr str) ;_拆分单字,没有下划线
  92.     l     (vl-remove-if-not
  93.         '(lambda (x) (vl-position (car x) '(1 40 7)))
  94.         el
  95.           ) ;_((1 . string) (40 . hight) (7 . style))
  96.     zl    (gettl l) ;_totl length
  97.     inspt (trans (cdr (assoc 10 el)) (cdr (assoc -1 el)) 0) ;_Insertpoint
  98.     p1    (trans p1 1 0)
  99.     pl    (* (distance inspt p1) (cos (- (angle inspt p1) an))) ;_拾取点到插入点的"距离"用于确定拾取位置的文字
  100.     nnstr nstr
  101.   )
  102.   (if p2
  103.     (setq p2  (trans p2 1 0)
  104.       pl1 (* (distance inspt p2) (cos (- (angle inspt p2) an)))
  105.     )
  106.   )
  107.   (if (or (<= 0. pl zl)
  108.       (<= 0. pl1 zl)
  109.       )
  110.     (progn
  111.       (while nnstr
  112.     (setq ll    (cons
  113.               (gettl
  114.             (list (cons 1 (apply 'strcat nnstr))
  115.                   h
  116.                   sty
  117.             )
  118.               )
  119.               ll
  120.             )
  121.           nnstr (cdr nnstr)
  122.     )
  123.       ) ;_单字到插入点的距离
  124.       (setq ll (cons 0. ll))
  125.       (mapcar '(lambda (x y z)
  126.          (if (<= x pl y)
  127.            (setq pstr z)
  128.          )
  129.            )
  130.           ll
  131.           (cdr ll)
  132.           nstr
  133.       ) ;_确定拾取位置文字
  134.       (if p2
  135.     (progn
  136.       (mapcar '(lambda (x y z)
  137.              (if (<= x pl1 y)
  138.                (setq pstr2 z)
  139.              )
  140.            )
  141.           ll
  142.           (cdr ll)
  143.           nstr
  144.       )
  145.       (setq    i1 (vl-position pstr nstr)
  146.         i2 (vl-position pstr2 nstr)
  147.         i  0
  148.       )
  149.       (if (< i1 i2)
  150.         (setq pstr (apply 'strcat
  151.                   (vl-remove nil
  152.                      (mapcar '(lambda (x / y)
  153.                             (if    (or (< i i1)
  154.                                 (> i i2)
  155.                             )
  156.                               (setq y nil)
  157.                               (setq y x)
  158.                             )
  159.                             (setq i (1+ i))
  160.                             y
  161.                           )
  162.                          nstr
  163.                      )
  164.                   )
  165.                )
  166.         )
  167.         (setq pstr (apply 'strcat
  168.                   (vl-remove nil
  169.                      (mapcar '(lambda (x / y)
  170.                             (if    (or (< i i1)
  171.                                 (> i i2)
  172.                             )
  173.                               (setq y nil)
  174.                               (setq y x)
  175.                             )
  176.                             (setq i (1+ i))
  177.                             y
  178.                           )
  179.                          nstr
  180.                      )
  181.                   )
  182.                )
  183.         )
  184.       )
  185.     )
  186.       ) ;_确定拾取位置文字
  187.     )
  188.   )
  189.   pstr
  190. )
  191. (defun c:tt (/ e el p1 p2 str ne)
  192.   (if (and (setq e (ssget ":L:S" '((0 . "text")))) ;_非锁定单选
  193.        (setq p1 (getpoint "\nFirst Point: "))
  194.        (setq p2 (getpoint p1 "\nSecond point: "))
  195.       )
  196.     (progn
  197.       (setq el    (entget (ssname e 0))
  198.         str    (xd::string:between el p1 p2)
  199.         el    (subst (cons 1 str) (assoc 1 el) el)
  200.         el    (subst (cons 10 p1) (assoc 10 el) el)
  201.       )
  202.       (setq ne (entget (entmakex el)))
  203.       (vl-cmdf ".move" "L" "" "_none" p1) ;_Move
  204.       (while (/= (getvar "cmdactive") 0)
  205.     (vl-cmdf pause)
  206.       )
  207.     )
  208.   )
  209.   ;;(princ zl)
  210.   (princ)
  211. )


评分

参与人数 2D豆 +15 收起 理由
/db_自贡黄明儒_ + 5 很给力!经验;技术要点;资料分享奖!
xshrimp + 10

查看全部评分

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!

已领礼包: 2476个

财富等级: 金玉满堂

发表于 2013-9-8 17:26:25 | 显示全部楼层
CAD版本2014 测试,数字复制正常,汉字不能正常复制。2004都能正常复制!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 2476个

财富等级: 金玉满堂

发表于 2013-9-8 17:28:37 | 显示全部楼层
奇怪,重启CAD后又能正常复制了,什么原因?
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 2476个

财富等级: 金玉满堂

发表于 2013-9-8 17:31:07 | 显示全部楼层
还是不太稳定!

点评

下午临时写的,还没有优化  详情 回复 发表于 2013-9-8 20:06
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 593个

财富等级: 财运亨通

 楼主| 发表于 2013-9-8 20:06:19 | 显示全部楼层
q3_2006 发表于 2013-9-8 17:31
还是不太稳定!

下午临时写的,还没有优化
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-9-9 05:38:16 | 显示全部楼层
p1 p2 判断待改进, 如果仅 p1 超出文字可以默认整个文字, 如果指定了 p1 p2 ,当 p2 超出文字默认到尾部
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 40个

财富等级: 招财进宝

发表于 2013-9-9 08:23:57 | 显示全部楼层
程序要考虑UCS,文字与WCS X轴有夹角的情况。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 6468个

财富等级: 富甲天下

发表于 2013-9-9 11:49:19 | 显示全部楼层
楼主有时间再优化下。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-11-13 20:13:21 | 显示全部楼层
不太理想,2006下测试正常,如果像您早年写的文本小厮那样有红色的范围显示就好了
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 604个

财富等级: 财运亨通

发表于 2013-11-14 09:38:59 | 显示全部楼层
站长,有没有升级版呀?{:soso_e113:}

点评

把这个忘了,这两天完善  详情 回复 发表于 2013-11-14 09:58
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 593个

财富等级: 财运亨通

 楼主| 发表于 2013-11-14 09:58:33 | 显示全部楼层
/db_自贡黄明儒_ 发表于 2013-11-14 09:38
站长,有没有升级版呀?

把这个忘了,这两天完善

点评

多行文字是不是一并考虑一下?因为对于用户来,就只是文字  详情 回复 发表于 2013-11-15 12:40
改进后,做个通用函数发布下,这个就先不收到函数库里面了。  详情 回复 发表于 2013-11-14 10:31
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 145个

财富等级: 日进斗金

发表于 2013-11-14 10:31:35 | 显示全部楼层
eachy 发表于 2013-11-14 09:58
把这个忘了,这两天完善

改进后,做个通用函数发布下,这个就先不收到函数库里面了。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 604个

财富等级: 财运亨通

发表于 2013-11-15 12:40:18 | 显示全部楼层
本帖最后由 /db_自贡黄明儒_ 于 2013-11-15 12:59 编辑
eachy 发表于 2013-11-14 09:58
把这个忘了,这两天完善


多行文字是不是一并考虑一下?因为对于用户来,就只是文字
p1 p2 用(ssnamex (ssget ":S" '((0 . "*text"))) 0)中的值代替,使用就更简单了

点评

黄老说了肯定要做到了  详情 回复 发表于 2013-11-15 14:40
对MTEXT而言有些特殊格式,这些格式不适用TEXT的,可能对MTEXT分成MTEXT更能保持原汁原味  详情 回复 发表于 2013-11-15 14:27
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 1268个

财富等级: 财源广进

发表于 2013-11-15 14:27:53 来自手机 | 显示全部楼层
/db_自贡黄明儒_ 发表于 2013-11-15 12:40
多行文字是不是一并考虑一下?因为对于用户来,就只是文字
p1 p2 用(ssnamex (ssget ":S" '((0 . "*tex ...

对MTEXT而言有些特殊格式,这些格式不适用TEXT的,可能对MTEXT分成MTEXT更能保持原汁原味
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 593个

财富等级: 财运亨通

 楼主| 发表于 2013-11-15 14:40:17 来自手机 | 显示全部楼层
/db_自贡黄明儒_ 发表于 2013-11-15 12:40
多行文字是不是一并考虑一下?因为对于用户来,就只是文字
p1 p2 用(ssnamex (ssget ":S" '((0 . "*tex ...


黄老说的肯定要做到了:)
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-3-29 08:58 , Processed in 0.405087 second(s), 64 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表