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

langjs

好久没写了，费劲

;;; ===================================================
;;; 功能：文字打断(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)
)

nochao

crtrccrt 发表于 2012-10-3 07:33
修改 2012-10-03  快捷键是大小写都支持

;;; ===================================================

要是能改为直接鼠标点击位置打我觉得会方便很多。

whuluqw

动态预览效果做得很好啊，不过用键盘移动的话要是文字很长就不方便了，要是鼠标也可以就完美了。哦，还有一个问题就是打断之后文字都对齐到断点的位置了

nochao

要是能改为直接鼠标点击位置打断的话会方便很多。

dcl1214

真是好人啊！！！！！！！！

461045462

谢谢楼主的分享！
先收藏，再慢慢学习领会。
谢谢！

lz123456

那快捷键最好是大小写都支持

Q1241274614

不错的程序，非常感谢！

tianyi1230

感谢郎大师，什么时候把文字搜索替换升级一下，

杨如迁

hao3ren

langjs 的东西都不错，顶一下

caogl1965

crtrccrt

一个字 很好 很好用