[LISP函数]：我编了一个文字对齐的程序，大家看看！

lgw

希望起到抛砖引玉的效果，那位再更新后，请上传，供大家分享。

梦断江南

既然没有设下载收币,不介意我把你的程序贴出来吧?

2. 
   
3. (progn
   
4. (setq ifhv nil)
   
5. (setq soname nil)
   
6. (setq lsoname nil)
   
7. (setq xyzsoname nil)
   
8. (setq ysoname nil)
   
9. (setq xsoname nil)
   
10. (setq fx nil fy nil fz nil)
    
11. (setq fysoname nil)
    
12. (setq fxyzsoname nil flsoname nil)
    
13. (setq fsname nil)
    
14. (setq lfxyz nil)
    
15. (setq flsoname nil)
    
16. (setq sobjectx nil)
    
17. 
    
18. (setvar "cmdecho" 0)
    
19. );;end progn
    
20. (defun C:tt ( )
    
21. 
    
22. (setq ifhv (getstring "please input Horiz or Vertical (H/<V>):"))
    
23. 
    
24. (if (or (= ifhv "h") (= ifhv "H"))
    
25. (progn
    
26. (prompt "please select a soure text for align:")
    
27. (setq sobjectx (ssget))
    
28. (setq soname (ssname sobjectx 0))
    
29. (setq lsoname (entget soname))
    
30. (setq xyzsoname (assoc '10 lsoname))
    
31. (setq ysoname (caddr xyzsoname))
    
32. 
    
33. ;;(print ysoname)
    
34. ;;(print soname)
    
35. 
    
36. (prompt "please select aligned text:")
    
37. (setq i 0)  
    
38. (setq ent (ssget '((0 . "TEXT"))))
    
39. (setq l (sslength ent))
    
40. (while (< i l)   
    
41. (progn
    
42. (setq fsname (ssname ent i))
    
43.   (setq flsoname (entget fsname))
    
44.   (setq fxyzsoname (assoc '10 flsoname))
    
45.   (setq fx (cadr fxyzsoname))
    
46.   (setq fz (caddr fxyzsoname))
    
47.   (setq lfxyz (list 10 fx ysoname fz))
    
48.   (setq flsoname (subst lfxyz (assoc 10 flsoname) flsoname))
    
49. ;;(print fx)
    
50. ;;(print fz)
    
51. ;;(print lfxyz)
    
52. ;; (print flsoname)
    
53.   (entmod flsoname)
    
54.   (entupd fsname)
    
55.   (setq i (1+ i))
    
56. )
    
57. )
    
58. (setq i nil)
    
59. (setq ent nil)
    
60. (setq l nil)
    
61. (princ)  ; Exit quietly.
    
62. 
    
63. );end progn
    
64. );end if
    
65. 
    
66. ;;;;;;;;;;;;;;;;;;;;;;;;X align
    
67. (progn
    
68. 
    
69. (prompt "please select a soure text for align:")
    
70. (setq sobjectx (ssget))
    
71. (setq soname (ssname sobjectx 0))
    
72. (setq lsoname (entget soname))
    
73. (setq xyzsoname (assoc '10 lsoname))
    
74. (setq xsoname (cadr xyzsoname))
    
75. 
    
76. (prompt "please select aligned text:")
    
77. (setq i 0)  
    
78. (setq ent (ssget '((0 . "TEXT"))))
    
79. (setq l (sslength ent))
    
80. (while (< i l)   
    
81. (progn
    
82. (setq fsname (ssname ent i))
    
83.   (setq flsoname (entget fsname))
    
84.   (setq fxyzsoname (assoc '10 flsoname))
    
85.   (setq fy (caddr fxyzsoname))
    
86.   (setq fz (cadddr fxyzsoname))
    
87.   (setq lfxyz (list 10 xsoname fy fz))
    
88.   (setq flsoname (subst lfxyz (assoc 10 flsoname) flsoname))
    
89. ;;(print fx)
    
90. ;;(print fz)
    
91. ;;(print lfxyz)
    
92. ;; (print flsoname)
    
93.   (entmod flsoname)
    
94.   (entupd fsname)
    
95.   (setq i (1+ i))
    
96. )
    
97. )
    
98. (setq i nil)
    
99. (setq ent nil)
    
100. (setq l nil)
     
101. (princ)  ; Exit quietly.
     
102. 
     
103. 
     
104. 
     
105. );end progn
     
106. 
     
107. 
     
108. 
     
109. 
     
110. )
     
111. 
     

<br /> (progn<br /> (setq ifhv nil)<br /> (setq soname nil)<br /> (setq lsoname nil)<br /> (setq xyzsoname nil)<br /> (setq ysoname nil)<br /> (setq xsoname nil)<br /> (setq fx nil fy nil fz nil)<br /> (setq fysoname nil)<br /> (setq fxyzsoname nil flsoname nil)<br /> (setq fsname nil)<br /> (setq lfxyz nil)<br /> (setq flsoname nil)<br /> (setq sobjectx nil)<br /> <br /> (setvar "cmdecho" 0)<br /> );;end progn<br /> (defun C:tt ( )<br /> <br /> (setq ifhv (getstring "please input Horiz or Vertical (H/<V>):"))<br /> <br /> (if (or (= ifhv "h") (= ifhv "H"))<br /> (progn<br /> (prompt "please select a soure text for align:")<br /> (setq sobjectx (ssget))<br /> (setq soname (ssname sobjectx 0))<br /> (setq lsoname (entget soname))<br /> (setq xyzsoname (assoc '10 lsoname))<br /> (setq ysoname (caddr xyzsoname))<br /> <br /> ;;(print ysoname)<br /> ;;(print soname)<br /> <br /> (prompt "please select aligned text:")<br /> (setq i 0)  <br /> (setq ent (ssget '((0 . "TEXT"))))<br /> (setq l (sslength ent))<br /> (while (< i l)   <br /> (progn<br /> (setq fsname (ssname ent i))<br />   (setq flsoname (entget fsname))<br />   (setq fxyzsoname (assoc '10 flsoname))<br />   (setq fx (cadr fxyzsoname))<br />   (setq fz (caddr fxyzsoname))<br />   (setq lfxyz (list 10 fx ysoname fz))<br />   (setq flsoname (subst lfxyz (assoc 10 flsoname) flsoname))<br /> ;;(print fx)<br /> ;;(print fz)<br /> ;;(print lfxyz)<br /> ;; (print flsoname)<br />   (entmod flsoname)<br />   (entupd fsname)<br />   (setq i (1+ i))<br /> )<br /> )<br /> (setq i nil)<br /> (setq ent nil)<br /> (setq l nil)<br /> (princ)  ; Exit quietly.<br /> <br /> );end progn<br /> );end if<br /> <br /> ;;;;;;;;;;;;;;;;;;;;;;;;X align<br /> (progn<br /> <br /> (prompt "please select a soure text for align:")<br /> (setq sobjectx (ssget))<br /> (setq soname (ssname sobjectx 0))<br /> (setq lsoname (entget soname))<br /> (setq xyzsoname (assoc '10 lsoname))<br /> (setq xsoname (cadr xyzsoname))<br /> <br /> (prompt "please select aligned text:")<br /> (setq i 0)  <br /> (setq ent (ssget '((0 . "TEXT"))))<br /> (setq l (sslength ent))<br /> (while (< i l)   <br /> (progn<br /> (setq fsname (ssname ent i))<br />   (setq flsoname (entget fsname))<br />   (setq fxyzsoname (assoc '10 flsoname))<br />   (setq fy (caddr fxyzsoname))<br />   (setq fz (cadddr fxyzsoname))<br />   (setq lfxyz (list 10 xsoname fy fz))<br />   (setq flsoname (subst lfxyz (assoc 10 flsoname) flsoname))<br /> ;;(print fx)<br /> ;;(print fz)<br /> ;;(print lfxyz)<br /> ;; (print flsoname)<br />   (entmod flsoname)<br />   (entupd fsname)<br />   (setq i (1+ i))<br /> )<br /> )<br /> (setq i nil)<br /> (setq ent nil)<br /> (setq l nil)<br /> (princ)  ; Exit quietly.<br /> <br /> <br /> <br /> );end progn<br /> <br /> <br /> <br /> <br /> )<br /> <br />

lgw

可是对于有些文字还是会出现问题阿！那位老兄再辛苦，完善一下。
斑竹阿，干吗贴出来阿，很寒颤阿。让我很害怕。别人会扔砖头的。

lgw

thank!
还有，能不能在选择源（对齐）文本的时候，自动就选择一个物体，不用回车了？

coolzhb

tt--运行文字对齐程序

流言不顺

看起来似乎很有用  我具体用一下 看看怎么样

dwgplt

很好用，谢谢你们。

2002zjp

好东西　谢谢

nxwuwei

好东西啊，我想要

xyp1964

试试签名栏下的“文本编辑套件”……

jinsong-liao

请哪位兄弟提供一个调整文字行间距的lisp源代码，非常感谢！

snoopychen

7楼楼主说：        
请哪位兄弟提供一个调整文字行间距的lisp源代码，非常感谢！

借用网上朋友的程序了
国内的（更实用一些）
[php]
;平均分布各行文字
;作者：吴殷飞
;作者单位：安庆市水利水电规划设计院
;禁止以商业为目的在网上传播
;如有疑问，请联系aqsssjy@mail.hf.ah.cn

(defun c:ath()

(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 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 x y z))
  (setq b (subst xyz_new (assoc '10 b) b))
  (entmod b)
  ;(entupd b)
  (setq m (1+ m))
)

)

[/php]

国外的
[php]
  ; Text Reshuffler - moves text vertically so that it is evenly
  ; spaced between two picked points - the top of the top line
  ; and the bottom of the bottom one.
  ; By SW for Rocket Software  Copyright 1991
(DEFUN C:SHUX ( / ss xa xb num incr txa txb nna enn nn yy ord)
  (setvar "cmdecho" 0)
  (command "undo" "mark")
  (prompt "Pick text strings: ")
  (setq ss (ssget)
        xa (getpoint "\nPick top line: ")
        num 0
        xb (getpoint xa "\nAnd bottom line: "))
;---------------Remove non-text entities from ss------------------
  (while (setq txb (ssname ss num))
         (if (= (cdr (assoc 0 (entget txb))) "TEXT")
             (setq num (1+ num))
             (ssdel txb ss)))
  (setq num 0)
;-----------------------------------------------------------------
  (setq ssl (sslength ss))
  (if (> ssl 1) (progn
  (setq ht (- (cadr xa) (cadr xb)))                   ; total height
  (setq txh (cdr (assoc 40 (entget (ssname ss 0)))))  ; text height
  (setq txht (* ssl txh))                             ; total txt ht
  (setq ht (- ht txht))                               ; difference
  (setq ht (/ ht (1- ssl)))                           ; spaces
  (setq incr (+ txh ht))
         (setq xa (list (car xa) (- (cadr xa) txh)))  
  (while (setq txa (ssname ss 0))
         (setq enn 1)
         (setq nna (entget txa))
         (setq ya (cdr (assoc 10 nna)))

;---------------See if next entity in ss is highest on screen-------
         (while (setq txb (ssname ss enn))
                (setq yb (cdr (assoc 10 (entget txb))))
                (if (> (cadr yb) (cadr ya))
                    (progn
                          (setq txa txb)
                          (setq nna (entget txa))
                          (setq ya (cdr (assoc 10 nna)))))
                (setq enn (1+ enn)))
         (setq num (1+ num))

;-------------------------Get registration type-----------------------
        (if (or (= (cdr (assoc 72 nna)) 2)
                 (= (cdr (assoc 72 nna)) 4)
                 (= (cdr (assoc 72 nna)) 1))
             (progn
                   (if (= (cdr (assoc 72 nna)) 4)
                       (progn
                             (setq yy (cdr (assoc 11 nna)))
                             (setq nn (list (car yy) (+ (/ txh 2)(cadr xa))))
                             (command "move" txa "" yy nn))
                       (progn
                             (setq yy (cdr (assoc 11 nna)))
                             (setq nn (list (car yy) (cadr xa)))
                             (command "move" txa "" yy nn))))
             (progn
                   (setq yy (cdr (assoc 10 nna)))
                   (setq nn (list (car yy) (cadr xa)))
                   (command "move" txa "" yy nn)))
         (ssdel txa ss)
         (setq xa (list (car xa) (- (cadr xa) incr))))
  ) (if (< 0 ssl)
        (write-line "\nThere aren't any spaces between one line.")))
  (setq ss nil)
  (if (> num 0)
      (prompt (strcat "\n" (ITOA num) " lines neatly stacked.")))
(PRINC))
[/php]

yybu

8楼楼主:
有没有能自已输入行间距值的LISP程序！

siyangyang

有没有能自已输入行间距值的LISP程序！

sfjlx

最初由 coolzhb 发布
[B]tt--运行文字对齐程序 [/B]

你发的与楼主的有什么区别啊？