[LISP程序]：我的LSP文字排版程式，很好用的。

sz961

2. ; 创作说明 文字排版程式。对DTXT有用！
   
3. ;此程序由seaon编写!
   
4. ;seaon@eyou.com
   
5. (defun c:Ts (/ pp2 startpts ss l ll fal th pt1 pty);start1
   
6.   (if (not (setq SS (ssget "i")))
   
7.     (progn
   
8.       (prompt "选择文字实体。\n")
   
9.       (setq SS (ssget))
   
10.     )
    
11.   )
    
12. (if (ssname ss 0)
    
13. (if (/= (cdr (assoc 0 (entget (ssname ss 0)))) "TEXT")
    
14. (progn
    
15. (alert " 所选实体中并非都是文字.ho-o! ")
    
16. (quit)
    
17. )))
    
18. 
    
19. (COMMAND "UNDO" "MARK")
    
20. (command "ucs" "w" )
    
21. (setvar "texteval" 1)(setq oldos (getvar "osmode"))
    
22. (setvar "osmode" 0)
    
23. 
    
24. (setq startpts (getpoint "输入起点位置："))
    
25. (print)
    
26. (if (= nil startpts);start2
    
27. (setq startpts (cdr (assoc 10 (entget (ssname ss 0)))))
    
28. );end2
    
29. 
    
30. (setq th (cdr (assoc 40 (entget (ssname ss 0)) )))
    
31. (setq startpts (list (car startpts) (- (car (cdr startpts)) (/ th 2))))
    
32. (if (= nil r )(setq r 0.67) (setq r (/ r (cdr (assoc 40 (entget (ssname ss 0)))) )))
    
33. (setq rr (getreal (strcat "输入行间距与字高的比例<" (rtos r 2 2) ">：")))
    
34. (if (/= nil rr)(setq r rr))
    
35. (if (or (= nil r) (= r 0.67))
    
36. (setq r (* 0.67 (cdr (assoc 40 (entget (ssname ss 0)))) ))
    
37. (setq r (* r (cdr (assoc 40 (entget (ssname ss 0))))))
    
38. )
    
39. (setq l (sslength ss))
    
40. (setq ii 0
    
41.       ooo t
    
42.       highy nil highent nil)
    
43. (setq endss (ssadd))
    
44. (repeat l
    
45. (repeat l
    
46. (if (ssname ss ii)
    
47.     (setq en (ssname ss ii))(setq ooo Nil)
    
48. )
    
49. (if (ssname ss ii)
    
50. (if (/= (cdr (assoc 0 (entget (ssname ss ii)))) "TEXT")
    
51. (progn
    
52. (alert " 所选实体中并非都是文字.ho-o! ")
    
53. (quit)
    
54. )))
    
55. (if (and ooo (= (cdr (assoc 0 (entget (ssname ss ii)))) "TEXT"))
    
56. (progn
    
57. (setq pt1 (car (cdr(cdr (assoc 10 (entget en))))))
    
58. 
    
59.    (if (> pt1 highy);start5
    
60.    (progn;start6
    
61.    (setq highy pt1)
    
62.    (setq highent en)
    
63.    ));end65
    
64. ))
    
65. (setq ii (1+ ii)
    
66.       ooo t
    
67.       )
    
68. );end repeat1
    
69. (setq ii 0 ooo t en nil)
    
70. (ssdel highent ss)
    
71. (ssadd highent endss)
    
72. (setq highy nil highent nil)
    
73. );end repeat2
    
74. 
    
75. (setq i 0)
    
76. (setq ll (sslength endss))
    
77. (repeat ll
    
78. (setq enn (ssname endss i))
    
79. (setq pp2 (cdr (assoc 10 (entget enn))))
    
80. (command "move" enn "" pp2 startpts)
    
81. (setq startpts (list (car startpts) (- (car (cdr startpts)) th r)))
    
82. (setq i (1+ i))
    
83. );end3 1
    
84. (command "ucs" "prev""")
    
85. (setvar "osmode" oldos)
    
86. )

; 创作说明 文字排版程式。对DTXT有用！<br /> ;此程序由seaon编写! <br /> ;seaon@eyou.com <br /> (defun c:Ts (/ pp2 startpts ss l ll fal th pt1 pty);start1 <br />   (if (not (setq SS (ssget "i"))) <br />     (progn <br />       (prompt "选择文字实体。\n") <br />       (setq SS (ssget)) <br />     ) <br />   ) <br /> (if (ssname ss 0) <br /> (if (/= (cdr (assoc 0 (entget (ssname ss 0)))) "TEXT") <br /> (progn <br /> (alert " 所选实体中并非都是文字.ho-o! ") <br /> (quit) <br /> ))) <br /> <br /> (COMMAND "UNDO" "MARK") <br /> (command "ucs" "w" ) <br /> (setvar "texteval" 1)(setq oldos (getvar "osmode")) <br /> (setvar "osmode" 0) <br /> <br /> (setq startpts (getpoint "输入起点位置：")) <br /> (print) <br /> (if (= nil startpts);start2 <br /> (setq startpts (cdr (assoc 10 (entget (ssname ss 0))))) <br /> );end2 <br /> <br /> (setq th (cdr (assoc 40 (entget (ssname ss 0)) ))) <br /> (setq startpts (list (car startpts) (- (car (cdr startpts)) (/ th 2)))) <br /> (if (= nil r )(setq r 0.67) (setq r (/ r (cdr (assoc 40 (entget (ssname ss 0)))) ))) <br /> (setq rr (getreal (strcat "输入行间距与字高的比例<" (rtos r 2 2) ">："))) <br /> (if (/= nil rr)(setq r rr)) <br /> (if (or (= nil r) (= r 0.67)) <br /> (setq r (* 0.67 (cdr (assoc 40 (entget (ssname ss 0)))) )) <br /> (setq r (* r (cdr (assoc 40 (entget (ssname ss 0)))))) <br /> ) <br /> (setq l (sslength ss)) <br /> (setq ii 0 <br />       ooo t <br />       highy nil highent nil) <br /> (setq endss (ssadd)) <br /> (repeat l <br /> (repeat l <br /> (if (ssname ss ii) <br />     (setq en (ssname ss ii))(setq ooo Nil) <br /> ) <br /> (if (ssname ss ii) <br /> (if (/= (cdr (assoc 0 (entget (ssname ss ii)))) "TEXT") <br /> (progn <br /> (alert " 所选实体中并非都是文字.ho-o! ") <br /> (quit) <br /> ))) <br /> (if (and ooo (= (cdr (assoc 0 (entget (ssname ss ii)))) "TEXT")) <br /> (progn <br /> (setq pt1 (car (cdr(cdr (assoc 10 (entget en)))))) <br /> <br />    (if (> pt1 highy);start5 <br />    (progn;start6 <br />    (setq highy pt1) <br />    (setq highent en) <br />    ));end65 <br /> )) <br /> (setq ii (1+ ii) <br />       ooo t <br />       ) <br /> );end repeat1 <br /> (setq ii 0 ooo t en nil) <br /> (ssdel highent ss) <br /> (ssadd highent endss) <br /> (setq highy nil highent nil) <br /> );end repeat2 <br /> <br /> (setq i 0) <br /> (setq ll (sslength endss)) <br /> (repeat ll <br /> (setq enn (ssname endss i)) <br /> (setq pp2 (cdr (assoc 10 (entget enn)))) <br /> (command "move" enn "" pp2 startpts) <br /> (setq startpts (list (car startpts) (- (car (cdr startpts)) th r))) <br /> (setq i (1+ i)) <br /> );end3 1 <br /> (command "ucs" "prev""") <br /> (setvar "osmode" oldos) <br /> )

hulinong

請問這是什么功能？

xzg_hello

我要好好参考一下

nt8011

我也用用看

lucy

请问sz961此lisp程序的功能是什么，试用了一下只有第一步能用，以后cad就不认命令ts了，原因何在，请指教！谢谢！

sz961

文字排版程式。对DTXT有用！文字对齐及行间距设定.对作表格很有用(如图纸目录)
lucy 你要把它保存成LISP文件.以后每次就可以调用了.

ligee

试用一下，不知排版功能有多强？

li809

大家用过了,觉得如何

hjmhjm

该命令ssget '((0 . "text"))可以只选择单行文本,其他图元均不选,版主可以采用并改进程序.

wym01lu

我也要来呀

1028882406@qq.c

谢谢楼主，支持下

1049955085ssd

你好，能帮我这一个小程序吗

xxpotential

好东西