- 积分
- 23758
- 明经币
- 个
- 注册时间
- 2002-7-9
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
修改 2012-10-03 快捷键是大小写都支持
;;; ===================================================
;;; 功能：文字打断(a d键改变分割的位置,左键确定,右键退出)
;;; 作者：langjs 命令:aa 日期:2012年9月
;;; 修改 2012-10-03 快捷键是大小写都支持
;;; ===================================================
(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 (= (strcase "a") (strcase (vl-list->string (cdr gr))))(> num 0))
(setq num (1- num))
)
((and (= (strcase "d") (strcase (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-10-3 07:33
显身卡