求多个单行文本的对齐程序

LXCH 发表于 2006-10-10 10:40:00

感觉我要找的程序应该有，但是没有找到。
要对图纸中的多个单行文本进行左对齐，能够调整行间距即可。
要lisp程序，因为还不会用别的程序。

david96007 发表于 2012-5-4 22:30:20

回楼上的，年代太久远了，代码自己都看不懂了！这个网站自己也有几年没来了，今天是搜索其他资料才回到这里。

ninja37 发表于 2020-11-1 18:27:09

david96007 发表于 2012-5-4 22:30
回楼上的，年代太久远了，代码自己都看不懂了！这个网站自己也有几年没来了，今天是搜索其他资料才回到这里 ...

岁月流逝了旧地重游一下

zhuquanmao 发表于 2006-10-10 11:25:00

;平均分布单行文字各行: (defun c:dqwb () (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)) ) )

LXCH 发表于 2006-10-10 14:49:00

谢谢。经试用程序有对齐功能，但是没有调整行距的功能。希望增加自定义行距的功能。

zhuquanmao 发表于 2006-10-10 21:24:00

你把文本第一行和最后一行的位置确定后，程序会根据这两个位置平均分布行距的。

LXCH 发表于 2006-10-12 08:18:00

由于不知道行距是多少，不能做到所有图纸中文字间距的统一，所以要自定义行距。

LXCH 发表于 2006-10-13 07:56:00

对楼上的程序进行了小改动，达到了要求。
(defun c:dqwb () (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);;按y坐标降序排列 (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 val (getreal "\n行距：")) (setq p (getpoint "\n首行的插入点：")) (setq x0 (car p)) (setq y0 (cadr p))
(setq m 0) (while (< m n) (setq b (nth m all)) (setq y (- y0 (* m val))) (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)) ) ) (princ "\n＝＝＝对齐单行文本，自定义行距程序成功加载！命令行以dqwb启动！")

gyxzzza 发表于 2006-10-15 13:50:00

好人真多啊！！

david96007 发表于 2006-10-21 22:34:00

((defun lconerr (s)
(if (/= s "Function cancelled")
(princ (strcat "\nError: " s))
) ;_ end of if
(setq text nil)
(setq *error* olderr)
(princ)
) ;_ end of defun
(defun getsel ()
(setq sel nil)
(princ "\n请选择要对齐的文字：")
(setq sel (ssget '((0 . "TEXT"))))
) ;_ end of defun
(defun C:TA (/ sel e dx dy el de num n x y ty inf olderr ab ac dc db)
 ;
(setq olderr*error*
 *error* lconerr
) ;_ end of setq
(initget 128 "M B T L R")
(setq
key (getkword
 "\nM左右中对齐/B底对齐/T顶对齐/R右对齐/<L左对齐> "
 ) ;_ end of getkword
) ;_ end of setq
(if (/= key nil)
(setq key (strcase key))
) ;_ end of if
;;;选择需要对齐的文字
(getsel)
(setq MuBiaoDian (getpoint "\n点取对齐点："))
;;;得到的点是当前坐标系的点
(setq sslen (sslength sel))
(setq test 0)
(while (< test sslen)
(setq TxTEnt (ssname sel test))
(setq TxtD (entget TxtEnt))
(setq GC72 (cdr (assoc 72 TxtD)))
(setq GC73 (cdr (assoc 73 TxtD)))
(if (and (= GC72 0) (= Gc73 0))
 (progn
 (setq InsP (cdr (assoc 10 TxtD))) ;世界坐标系
 ) ;_ end of progn
 (progn
 (setq InsP (cdr (assoc 11 TxtD))) ;世界坐标系
 ) ;_ end of progn
) ;_ end of if
(setq UInsP (Trans InsP 0 1)) ;转化为当前坐系
(if (or (= key "L")
 (= key nil)
 ) ;_ end of or
 (progn
 (ChGC TxTEnt 72 0 ;|nil nil|; 73 0)
 (ChC TxtEnt UInsp MuBiaoDian 10 "X")
 ) ;_ end of progn
 (if (= key "R")
 (progn
 (ChGC TxTEnt 72 2 nil nil ;|73 0|;)
 (ChC TxtEnt UInsp MuBiaoDian 11 "X")
 ) ;_ end of progn
 (if (= key "T")
 (progn
 (ChGC TxTEnt ;| 72 1 |; nil nil 73 3)
 (ChC TxtEnt UInsp MuBiaoDian 11 "Y")
 ) ;_ end of progn
 (if (= key "B")
 (progn
 (ChGC TxTEnt ;| 72 1|; nil nil 73 1)
 (ChC TxtEnt UInsp MuBiaoDian 11 "Y")
 ) ;_ end of progn
 (if (= key "M")
 (progn
 (ChGC TxTEnt 72 1 nil nil ;|73 0|;)
 (ChC TxtEnt UInsp MuBiaoDian 11 "X")
 ) ;_ end of progn
 ) ;_ end of if
 ) ;_ end of if
 ) ;_ end of if
 ) ;_ end of if
) ;_ end of if
(setq test (1+ test))
) ;_ end of while
(setq *error* olderr)
(gc)
(princ)
) ;_ end of defun
(defun ChGC (TxtEnt GroCod_1 GroCodVal_1 GroCod_2 GroCodVal_2 /)
(setq ED (entget TxtEnt))
(if (/= GroCod_1 nil)
(setq ED (subst (cons GroCod_1 GroCodVal_1) (assoc GroCod_1 ED) ED))
) ;_ end of if
(if (/= GroCod_2 nil)
(setq ED (subst (cons GroCod_2 GroCodVal_2) (assoc GroCod_2 ED) ED))
) ;_ end of if
(entmod ED)
(entupd TxtEnt)
) ;_ end of defun
(defun ChC (TxTEnt UInp MuBDn GroCod XY /)
(if (= XY "Y")
(setq WInp (trans (list (car UInp)
 (cadr MuBDn)
 (caddr UInp)
 ) ;_ end of list
 1
 0
 ) ;_ end of trans
) ;_ end of setq
(if (= XY "X")
 (setq WInp (trans (list (car MuBDn)
 (cadr UInp)
 (caddr UInp)
 ) ;_ end of list
 1
 0
 ) ;_ end of trans
 ) ;_ end of setq
) ;_ end of if
) ;_ end of setq
(setq NInp (list GroCod
 (car WInp)
 (cadr WInp)
 (caddr WInp)
 ) ;_ end of setq
) ;_ end of setq
(setq TtD (entget TxtEnt))
(setq TtD (subst NInp (assoc GroCod TTD) TTD))
(entmod TtD)
(entupd TxTEnt)
) ;_ end of defun

8350 发表于 2006-10-22 08:07:00

怎么会这样
 
命令: _appload 已成功加载   lconerr.lsp。 命令: ; 错误: 输入的列表有缺陷
命令: ta TABLET 定点设备不能用作数字化仪。

GamIng 发表于 2011-11-27 09:40:48

本帖最后由 GamIng 于 2011-11-27 09:41 编辑

david96007 发表于 2006-10-21 22:34 http://bbs.mjtd.com/static/image/common/back.gif

8楼程序，如果文字有旋转（角度）程序执行结果是错误的。旋转90°时，文字是叠在一块。

页: [1] 2

明经CAD社区's Archiver

求多个单行文本的对齐程序