[LISP程序]：几个文字处理程序

lingzhi0512

;;;运行命令textout，设置文本文件的位置，然后选择一大段（多行）单行文本，将选定的单行文本输出到指定文件:
;;; TextOut.lsp
;;;运行命令textin，输入起始点、字高、行高，然后在硬盘上找到含有大段文字（如设计总说明），将指定文件中的文本以单行文字的形式写到CAD:
;;; TextIn.lsp
;;;运行命令textinput，设置起始点、字高、行高，打开记事本输入大段文字，将所输入的文字以单行文字的形式写到CAD:
;;; TextInput.lsp
;;;运行命令textedit，选择大段单行文字，将打开记事本编辑这些文字：
;;; TextEdit.lsp
;;;运行命令tv，选择大段单行文本，将平均分布大段单行文字的行间距：
;;; TV.lsp
;;;运行命令tv，选择大段单行文本，将重新设置大段单行文字的行间距和字高
;;; TVV.lsp



[php]
;;;输出选定多行的单行文本到指定文件:

;;; TextOut.lsp
(defun c:TextOut ( / flnm fn index num0 num1 sslist sslson0 sslson1 ssnum ssour txt)
        (setvar "cmdecho" 0)
        ;;打开文件
        (setq flnm (getstring "\n输入文件路径文件<浏览...>:"))
        (if flnm (setq flnm (getfiled "文本文件" "CADText" "txt" 13)))
        (setq fn (open flnm "w"))
        ;;选择文字，并保持文字原来的排版顺序不变
        (setq ssour (ssget (list (cons 0 "TEXT"))))
        (setq ssnum (sslength ssour))
        (setq sslist nil)
        (setq index 0)
        (while (< index ssnum)
                (setq sslist (append sslist (list (entget (ssname ssour index)))))
                (setq index (1+ index))
        )
        (setq num0 0)
        (setq num1 1)
        (while (< num0 ssnum)
                (setq sslson0 (nth num0 sslist))
                (while (< num1 ssnum)
                        (setq sslson1 (nth num1 sslist))
                        (if (> (nth 2 (assoc '10 sslson1)) (nth 2 (assoc '10 sslson0)))
                                (progn
                                        (setq sslist (subst 'num00 (nth num0 sslist) sslist))
                                        (setq sslist (subst 'num11 (nth num1 sslist) sslist))
                                        (setq sslist (subst sslson1 'num00 sslist))
                                        (setq sslist (subst sslson0 'num11 sslist))
                                        (setq sslson0 sslson1)
                                )
                        )
                (setq num1 (1+ num1))
                )
                (setq num0 (1+ num0))
                (setq num1 (1+ num0))
        )
        ;;依次读取文字并写入到文件
        (setq index 0)
        (while (< index ssnum)
                (setq txt (cdr (assoc 1 (nth index sslist))))
                (write-line txt fn)
                (setq index (1+ index))
        )
        (prompt "\n文本导出:TextOut")
        (setvar "cmdecho" 1)
        (princ)
)[/php]

[php]
;;;将指定文件中的多行文本以单行文字的形式写到CAD:

;;; TextIn.lsp
(defun c:TextIn ()
        (setvar "cmdecho" 0)
        (setq piont (getpoint "\n输入文字起点:"))
        (setq txtH (getdist piont "\n输入文字高度<5>:"))
        (setq txtH (if (= txtH nil) 5.0 txtH))
        (setq rowH (getdist piont "\n输入文字行间距<8>:"))
        (setq rowH (if (= rowH nil) 8.0 rowH))
        (setq flnm (getstring "\n输入文件路径文件<浏览...>:"))
        (if flnm (setq flnm (getfiled "文本文件" "CADText" "txt" 4)))
        (setq fn (open flnm "r"))
        (setq x0 (car piont))
        (setq y0 (car (cdr piont)))
        (setq index 0)
        (while (setq txt (read-line fn))
                (setq y (- y0 (* index rowH)))
                (entmake (list '(0 . "text") (cons 1 txt)
                                                                                (cons 10 (list x0 y 0)) (cons 40 txtH)
                                                                                 '(72 . 0) '(73 . 0)
                                                        )
                )
                (setq index (1+ index))
        )
        (close fn)
        (setvar "cmdecho" 1)
        (princ)
)
[/php]


[php]
;;;用记事本输入多行的单行文字：

(defun c:TextInput ( / flnm fn index piont rowh txt txth x0 y y0)
        (setvar "cmdecho" 0)
        (setq piont (getpoint "\n输入文字起点:"))
        (setq txtH (getdist piont "\n输入文字高度<5>:"))
        (setq txtH (if (= txtH nil) 5.0 txtH))
        (setq rowH (getdist piont "\n输入文字行间距<8>:"))
        (setq rowH (if (= rowH nil) 8.0 rowH))
        (setq flnm "mytemp.txt")
        (setq fn (open flnm "w"))
        (close fn)
        (dos_exewait "notepad.exe mytemp.txt")
        (setq fn (open flnm "r"))
        (setq x0 (car piont))
        (setq y0 (car (cdr piont)))
        (setq index 0)
        (while (setq txt (read-line fn))
                (setq y (- y0 (* index rowH)))
                (command "text" "j" "bl" (list x0 y 0.0) txtH 0 txt)
                (setq index (1+ index))
        )
        (close fn)
        (setvar "cmdecho" 1)
        (princ)
)
[/php]

[php]
;;;用记事本编辑多行的单行文本：

(defun c:textedit ( / flnm fn index lay num0 num1 rowh sslist sslson0 sslson1 ssnum ssour sty texth txt x0 y y0 yend)
        ;;选择文字
        (setq ssour (ssget (list (cons 0 "TEXT"))))
        (setq ssnum (sslength ssour))
        (setq sslist nil)
        ;;定义字高和行距
        (setq textH (getreal "\n输入新的文字高度<不改变>:"))
        (setq rowH (getreal "\n输入新的行间距(相邻行文字插入点之间的距离)<不改变>:"))
        ;;保持文字原来排版方式不变
        (setq index 0)
        (while (< index ssnum)
                (setq sslist (append sslist (list (entget (ssname ssour index)))))
                (setq index (1+ index))
        )
        (setq num0 0)
        (setq num1 1)
        (while (< num0 ssnum)
                (setq sslson0 (nth num0 sslist))
                (while (< num1 ssnum)
                        (setq sslson1 (nth num1 sslist))
                        (if (> (nth 2 (assoc '10 sslson1)) (nth 2 (assoc '10 sslson0)))
                                (progn
                                        (setq sslist (subst 'num00 (nth num0 sslist) sslist))
                                        (setq sslist (subst 'num11 (nth num1 sslist) sslist))
                                        (setq sslist (subst sslson1 'num00 sslist))
                                        (setq sslist (subst sslson0 'num11 sslist))
                                        (setq sslson0 sslson1)
                                )
                        )
                (setq num1 (1+ num1))
                )
                (setq num0 (1+ num0))
                (setq num1 (1+ num0))
        )
        (setq x0 (nth 1 (assoc '10 (nth 0 sslist)))
                                y0 (nth 2 (assoc '10 (nth 0 sslist)))
                                yend (nth 2 (assoc '10 (nth (1- ssnum) sslist)))
                                sty (cdr (assoc '7 (nth 0 sslist)))
                                lay (cdr (assoc '8 (nth 0 sslist)))
        )
        (if (= nil textH) (setq textH (cdr (assoc '40 (nth 0 sslist)))))
        (if (= nil rowH) (setq rowH (/ (- y0 yend) (1- ssnum))))
        ;;将文字内容保存到文件
        (setq flnm "mytemp.txt")
        (setq fn (open flnm "w"))
        (setq index 0)
        (repeat ssnum
                (write-line (cdr (assoc 1 (nth index sslist))) fn)
                (setq index (1+ index))
        )
        (close fn)
        ;;开始写入CAD
        (dos_exewait "notepad.exe mytemp.txt")
        (setq fn (open flnm "r")
                                index 0
        )
        (command "erase" ssour "")
        (while (setq txt (read-line fn))
                (setq y (- y0 (* index rowH)))
                (entmake (list '(0 . "text") (cons 1 txt) (cons 7 sty) (cons 8 lay)
                                                                                (cons 10  (list x0 y 0)) (cons 40 textH) '(41 . 0.7)
                                                                                 '(72 . 0) '(73 . 0)
                                                        )
                )
                (setq index (1+ index))
        )
        (close fn)
        (setvar "cmdecho" 1)
        (princ)
)
[/php]

[php]
;;;平均分布大段单行文字的行间距：

(defun c:TV ()
        (setq a (ssget (list (cons 0 "text"))))
        (setq n (sslength a))
        (setq all nil)
        (setq m 0)
        (while (< m n)
                (setq all (append        all (list (entget (ssname a m)))))
                (setq m (1+ m))
        )
        (setq l 0)
        (setq m 1)
        (while (< l n)
                (setq b (nth l all))
                (while (< m n)
                        (setq c (nth m all))
                        (if (> (nth 2 (assoc '10 c)) (nth 2 (assoc '10 b)))
                                (progn
                                        (setq all (subst 'aa (nth l all) all ) )
                                        (setq all (subst 'bb (nth m all) all ) )
                                        (setq all (subst c 'aa all ) )
                                        (setq all (subst b 'bb all ) )
                                        (setq b c)
                                )
                        )
                        (setq m (1+ m))
                )
                (setq l (1+ l))
                (setq m (1+ l))
        )
        (setq a (nth 0 all))
        (setq b (nth (1- n) all))
        (setq detay (/ (- (nth 2 (assoc '10 a)) (nth 2 (assoc '10 b))) (1- n) ) )
        (setq x0 (nth 1 (assoc '10 a)))
        (setq y0 (nth 2 (assoc '10 a)))
        (setq m 0)
        (while (< m n)
                (setq b (nth m all))
                (setq x (nth 1 (assoc '10 b)))
                (setq y (- y0 (* m detay)))
                (setq z (nth 3 (assoc '10 b)))
                (setq xyz_new (list '10 x0 y z))
                (setq b (subst (cons '72 0) (assoc '72 b) b))
                (setq b (subst (cons '73 0) (assoc '73 b) b))
                (setq b (subst xyz_new (assoc '10 b) b ) )
                (entmod b)
                (setq m (1+ m))
        )
)

[/php]

[php]
;;;重新设置大段单行文字的行间距和字高

(defun c:tvv ( / index num0 num1 rowh sslist sslistson sslistson0 sslson0 sslson1 ssnum ssour texth x0 y y0 z)
        ;;选择文字
        (setq ssour (ssget (list (cons 0 "TEXT"))))
        (setq ssnum (sslength ssour))
        (setq sslist nil)
        ;;定义字高和行距
        (setq textH (getreal "\n输入新的文字高度<4>:"))
        (setq textH (if (= textH nil) 4.0 textH))
        (setq rowH (getreal "\n输入新的行间距(相邻行文字插入点之间的距离)<7>:"))
        (setq rowH (if (= rowH nil) 7.0 rowH))
        ;;保持文字原来排版方式不变
        (setq index 0)
        (while (< index ssnum)
                (setq sslist (append sslist (list (entget (ssname ssour index)))))
                (setq index (1+ index))
        )
        (setq num0 0)
        (setq num1 1)
        (while (< num0 ssnum)
                (setq sslson0 (nth num0 sslist))
                (while (< num1 ssnum)
                        (setq sslson1 (nth num1 sslist))
                        (if (> (nth 2 (assoc '10 sslson1)) (nth 2 (assoc '10 sslson0)))
                                (progn
                                        (setq sslist (subst 'num00 (nth num0 sslist) sslist))
                                        (setq sslist (subst 'num11 (nth num1 sslist) sslist))
                                        (setq sslist (subst sslson1 'num00 sslist))
                                        (setq sslist (subst sslson0 'num11 sslist))
                                        (setq sslson0 sslson1)
                                )
                        )
                (setq num1 (1+ num1))
                )
                (setq num0 (1+ num0))
                (setq num1 (1+ num0))
        )
        ;;重新设置文字高度和行间距
        (setq sslistson0 (nth 0 sslist))
        (setq x0 (nth 1 (assoc '10 sslistson0)))
        (setq y0 (nth 2 (assoc '10 sslistson0)))
        (setq index 0)
        (while (< index ssnum)
                (setq sslistson (nth index sslist))
                (setq y (- y0 (* index rowH)))
                (setq z (nth 3 (assoc '10 sslistson)))
                (setq sslistson (subst (list '10 x0 y z) (assoc '10 sslistson) sslistson))
                (setq sslistson (subst (cons '40 textH) (assoc '40 sslistson) sslistson))
                (setq sslistson (subst (cons '72 0) (assoc '72 sslistson) sslistson))
                (setq sslistson (subst (cons '73 0) (assoc '73 sslistson) sslistson))
                (entmod sslistson)
                (setq index (1+ index))
        )       
)
[/php]

小院人

楼上的介绍一下你的程序功能和优点好让我等菜鸟能明白呀

rungang2002

这太有用啦,在写说明了时省时不小

haibinpro

像是好东西.

jianying17

有代码就是不知道怎么用，哎，好悲哀啊，希望贵论坛能够做一些很基础很基础的文档，让我们这些菜鸟学习学习啊，

w379106181

谢谢分享谢谢分享谢谢分享谢谢分享谢谢分享谢谢分享谢谢分享谢谢分享谢谢分享谢谢分享谢谢分享