某网友要的文字打断程序,做好了进来下载吧
好久没写了，费劲;;; ===================================================
;;; 功能：文字打断(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 1str "" )
(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 (appenda_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 键改变分割的位置,左键确定,右键退出:")
(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)
)
crtrccrt 发表于 2012-10-3 07:33
修改 2012-10-03快捷键是大小写都支持
;;; ===================================================
要是能改为直接鼠标点击位置打我觉得会方便很多。 动态预览效果做得很好啊，不过用键盘移动的话要是文字很长就不方便了，要是鼠标也可以就完美了。哦，还有一个问题就是打断之后文字都对齐到断点的位置了 要是能改为直接鼠标点击位置打断的话会方便很多。 真是好人啊！！！！！！！！ 谢谢楼主的分享！
先收藏，再慢慢学习领会。
谢谢！
那快捷键最好是大小写都支持 不错的程序，非常感谢！ 感谢郎大师，什么时候把文字搜索替换升级一下， langjs 的东西都不错，顶一下 一个字 很好 很好用