明经CAD社区

 找回密码
 注册

扫一扫,访问微社区

QQ登录

只需一步,快速开始

查看: 4077|回复: 22

某网友要的文字打断程序,做好了进来下载吧

  [复制链接]
发表于 2012-9-28 14:14 | 显示全部楼层 |阅读模式
好久没写了,费劲

;;; ===================================================
;;; 功能:文字打断(a d键改变分割的位置,左键确定,右键退出)
;;; 作者:langjs      命令:aa     日期:2012年9月
;;; ===================================================
(defun c:aa (/ a_data a_list ang box code color data ent ent2 gr i lst m n name name2 nn num num2 pt pt1 pt2 ss sss str strlst texth
               txt w x
            )
  (defun sublst (lst n m / i str x)    ; 提取表中元素组成字符串
    (setq i 1  str "" )
    (foreach x lst
      (progn
        (if (and (>= i n) (<= i m)) (setq str (strcat str x)))
        (setq i (1+ i))
      ))
    str
  )
  (defun stringtolist (sss / a_data a_list nn) ; 分解字符串成表
    (while (/= sss "")
      (setq a_data (logand 224 (ascii sss)))
      (if (or (= a_data 224)   (= a_data 128))
        (progn
          (setq a_list (append a_list(list (substr sss 1 2))))
          (setq sss (substr sss 3))
        )
        (progn
          (if (> (ascii (setq nn (substr sss 1 1))) 160)
            (setq nn (substr sss 1 2) sss (substr sss 3))
            (setq sss (substr sss 2))
          )
          (setq a_list (append  a_list (list nn) ) )
        )))
    a_list
  )
  (defun makepline (pt1 pt2 w color / ent name) ; 生成线
    (setq ent (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 62 color) (cons 90 2)
                             (cons 43 w) (cons 10 pt1) (cons 10 pt2)
                       )))
    (setq name (entlast))
    name
  )
  (defun #err988 (s)                   ; 出错处理
    (entdel name2)
    (setq *error* $orr)
  )
  (setvar "cmdecho" 0)
  (vl-load-com)
  (setq $orr *error*)
  (setq *error* #err988)
  (while (not (setq ss (ssget ":E:S" '((0 . "TEXT")))))
    (if (= (getvar "ERRNO") 52) (vl-exit-with-error ""))
  )
  (setq name (ssname ss 0)   ent (entget name)  txt (cdr (assoc 1 ent))
        pt (cdr (assoc 10 ent)) texth (cdr (assoc 40 ent)) ang (cdr (assoc 50 ent))
        name2 (makepline pt (polar pt (+ ang (/ pi 2)) texth) (* 0.05 texth) 1)
        strlst (stringtolist txt)    num 0    num2 (length strlst)
  )
  (princ "\n [A] [D] 键改变分割的位置,左键确定,右键退出:")
  (while (progn
           (setq gr (grread t 15 0)  code (car gr)  data (cadr gr) )
           (cond
             ((= code 2)
               (cond
                 ((and (= "a" (vl-list->string (cdr gr)))(> num 0))
                   (setq num (1- num))
                 )
                 ((and (= "d" (vl-list->string (cdr gr)))(< num (length strlst)))
                   (setq num (1+ num))
                 )
               )
               (entdel name2)
               (if (= num 0)
                 (setq name2 (makepline pt (polar pt (+ ang (/ pi 2)) texth) (* 0.05 texth) 1))
                 (setq ent2 (cdr (subst (cons 1 (sublst strlst 1 num))(assoc 1 ent)  ent ))
                       box (textbox ent2) pt1 (polar pt ang (+ (car (car (cdr box))) (car (car box))))
                       name2 (makepline pt1 (polar pt1 (+ ang (/ pi 2)) texth) (* 0.05 texth) 1)
                 ))
             )
             ((= code 3)
               (if (or (= num 0)(= num num2))
                 (entdel name2)
                 (progn
                   (entdel name)
                   (entmake ent2)
                   (entdel name2)
                   (setq ent2 (subst (cons 1 (sublst strlst (1+ num) num2)) (assoc 1 ent) ent ))
                   (entmake (subst (cons 10 pt1)(assoc 10 ent2) ent2))
                 ))
               (vl-exit-with-error "")
             )
             ((or (= code 11) (= code 25))
               (entdel name2)
               (vl-exit-with-error "")
             )
           )
           t
         )
  )
  (setq *error* $orr)
  (princ)
)



点评

大师的精神是明经上的榜样,请大师有空时能不能写一个程序,把图中所有各种标注的精度设置为小数点后几位数的程序啊。  发表于 2012-11-7 12:12
看标题就知道是个好人  发表于 2012-9-28 20:07

评分

参与人数 1明经币 +1 收起 理由
lohas1118 + 1 赞一个!

查看全部评分

发表于 2012-9-28 14:31 | 显示全部楼层
真是好人啊!!!!!!!!
发表于 2012-9-28 15:17 | 显示全部楼层
谢谢楼主的分享!
先收藏,再慢慢学习领会。
谢谢!
发表于 2012-9-28 19:39 | 显示全部楼层
那快捷键最好是大小写都支持
发表于 2012-9-28 20:29 | 显示全部楼层
不错的程序,非常感谢!
发表于 2012-9-28 21:31 | 显示全部楼层
感谢郎大师,什么时候把文字搜索替换升级一下,
发表于 2012-9-28 23:45 | 显示全部楼层
发表于 2012-9-29 09:54 | 显示全部楼层
langjs 的东西都不错,顶一下
发表于 2012-9-29 15:51 | 显示全部楼层
发表于 2012-10-3 07:29 | 显示全部楼层
一个字 很好 很好用
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号  
©2000-2017 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2018-12-19 01:32 , Processed in 0.272123 second(s), 35 queries , Gzip On.

Powered by Discuz! X3.3

© 2001-2013 Comsenz Inc.

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