论坛 › A/VLISP › [LISP程序]：给文字加下划线的小工具

xiagood 发表于 2009-3-4 10:16:37

[LISP程序]：给文字加下划线的小工具

一个给文字加下划线的lisp.供大家参考使用。谢谢!

;;;程序名： UL
;;;用途：给多行文本、单行文本增减下划线.
;;;日期：2009/03/04
;;;作者：xiatian3639@sina.com

;;;-----------------------------增减文字下划线-----------------------------
(Defun ErrorUL(msg)
   (prin1)
)

(Defun C:UL(/ Textsel L N UlTxt UlEntget UlTxtCon UlTxtTyp UlFlag UlNewTxt)
(setvar "cmdecho" 0)
(setq *error* ErrorUL)
(princ "\n选择需增减下划线文字:")
(setq Textsel (ssget '((-4 . "<OR")
                   (0 . "TEXT")
                   (0 . "MTEXT")
                   (-4 . "OR>"))
               ))
(if (/= Textsel nil)
      (progn
           (setq L0)
           (setq N (sslength Textsel))
           (while (< L N)
              (setq UlTxt (ssname TextSel L))
              (setq UlEntget (entget Ultxt))
              (setq UlTxtCon (cdr (assoc 1 UlEntget)))
              (setq UlTxtTyp (cdr (assoc 0 UlEntget)))
              (if (= UltxtTyp "TEXT")
                  (progn
                      (setq UlFlag (substr UlTxtCon 1 3))
                      (if (= UlFlag "%%U")
                        (setq UlNewTxt (substr UlTxtCon 4))
                        (setq UlNewTxt (strcat "%%U" UlTxtCon))
                      )
                   )
                   (progn
                      (setq UlFlag (substr UlTxtCon 1 3))
                      (if (= UlFlag "{\\L")
                        (setq UlNewTxt (substr UlTxtCon 4 (- (strlen UlTxtCon) 4)))
                        (setq UlNewTxt (strcat "{\\L" UlTxtCon "}"))
                      )
                   )
                )
              (setq UlEntget (subst (cons 1 UlNewTxt) (assoc 1 UlEntget) UlEntget))
              (entmod UlEntget)
              (setq L (+ L 1))
           )
        )
      (princ "\n未处理任何文字对象！")
    )
   (prin1)
)

jichengxing 发表于 2009-3-4 15:06:02

看看

kevinsjw 发表于 2009-3-4 22:37:43

有点意思啊

shenying123 发表于 2009-3-5 09:18:14

有点意思啊

lxch 发表于 2009-3-6 15:42:40

谢谢，试用了，感觉线有点短，应该调整哪里？

qddlm 发表于 2009-3-7 07:48:49

不错，实用小东东

belx 发表于 2009-3-13 14:49:03

APPLOAD 已成功加载 增减文字下划线.lsp。
命令: ; 错误: 输入的点对中含有多余的 cdrs

userzhluserzhl 发表于 2009-3-13 15:09:44

加图名线示范

ljttjl 发表于 2009-3-14 19:24:36

也可以使用以下程序（文字带下划线），见附件xswzcs.rar

zhengchuan1971 发表于 2009-3-20 14:14:36

有点意思啊

szlmh 发表于 2009-3-24 12:19:50

好像不错，是不是公开的源码

ynjzlzd 发表于 2009-3-25 09:11:01

麻烦楼主做一个文字加上划线的，且上划线与文字距离2－3mm,有时要用到。

tanle2020 发表于 2009-4-8 08:32:04

同7楼的一样，不知道是什么原因

chinalgy 发表于 2009-4-8 21:22:01

不错啊，好东西，。。学习一下。。

njutfyj 发表于 2009-4-13 00:01:27

谢谢各位楼主了

查看完整版本: [LISP程序]：给文字加下划线的小工具