本帖最后由 tryhi 于 2025-12-5 15:14 编辑
挺好的，提2个建议，
1、变量修改建议在ssget之后，否则如果*error*没触发（调试环境下）会导致使用后变量没有成功恢复，导致用完之后move跟copy命令无预览
2、同个单元格如果两个文本会重叠在一起
本帖最后由 wudechao 于 2025-12-10 13:16 编辑
；文字表格秒居中（交叉线判断版）,比bpoly方法快多了,支持天正字体和多行文字，表格不封闭也可以。
(defun c:wzjz (/ *error* oos en ss n ptm disn diss dise disw date1 xx yy pt-dis dis zg time)
(defun ffg-near-point-line (pt ang scsz / ss3 m en3 ent3 ty ent2 ptj lst ang1 dis-min);;求一个点沿某个方向最近的直线和距离(scsz为距离，为加快判断速度而设置)
(vl-load-com)
(setq ss3 (ssget "f" (list pt (polar pt ang scsz)) (list '(-4 . "<AND") '(0 . "LINE,LWPOLYLINE,POLYLINE") '(8 . "~DEFPOINTS")
'(8 . "~校对") '(-4 . "AND>")
)
)
lst '()
)
(if ss3
(progn
(setq m 0)
(while (setq en3 (ssname ss3 m))
(setq ent2 (entget en3)
ty (assoc 0 ent2)
)
(if (or
(= "LWPOLYLINE" (cdr ty))
(= "POLYLINE" (cdr ty))
)
(progn
(entmake (list '(0 . "LINE") (cons 10 pt) (cons 11 (polar pt ang scsz))))
(setq ent3 (entlast))
(setq ptj (vlax-invoke (vlax-ename->vla-object en3) 'intersectwith (vlax-ename->vla-object ent3) 0));返回曲线上与直线相交点
(entdel ent3)
(if (> (length ptj) 3);多于两个相交点
(setq ptj (list (car ptj) (cadr ptj) (caddr ptj)))
)
)
(progn
(setq ptj (trans (vlax-curve-getclosestpointto en3 (trans pt 1 0) t) 0 1));返回曲线上离指定点最近的点（在 ucs 上）
);_结束progn
);_结束if
(if ptj
(progn
(setq ang1 (angle pt ptj));以下代码是取线段角度，剔除斜线
(if (equal ang1 (* 2 pi) 0.087266);355~360之间的角度设置为0,否则无法判断比如359.99度与0度是否相等
(setq ang1 (* 2 pi))
)
(setq ang1 (rem ang1 (* 2 pi)));对360度取余
(if (equal ang1 ang 0.087266);误差5度
(setq lst (cons (list (distance pt ptj) en3) lst));距离和线组合的表
)
)
nil;没有相交点
)
(setq m (1+ m))
);_结束while
(setq dis-min (apply
'min
(mapcar
'car
lst
)
)
)
(assoc dis-min lst)
);_结束progn
nil;没有相交点
)
);_结束defun
(defun ffg-txt-mid-ptlong (en2 / ent4 box ls pt4 ang4 pt-dis2 ty p1 p2 kuandu gaodu pt0 bbox);;;求文字的中心点和字对角线距离
(setq ent4 (entget en2))
(setq ty (cdr (assoc 0 (entget en2))))
(cond
((or
(= ty "TCH_MTEXT")
(= ty "TCH_TEXT")
)
(setq bbox (vla-getboundingbox (vlax-ename->vla-object en2) 'p1 'p2))
(setq p1 (vlax-safearray->list p1)
p2 (vlax-safearray->list p2)
)
(setq midpt (mapcar
'(lambda (a b)
(* 0.5 (+ a b))
)
p1
p2
)
)
(setq pt-dis2 (list (trans midpt 0 1) (abs (distance p1 p2))))
);_结束
((= ty "MTEXT")
(setq kuandu (cdr (assoc 42 (entget en2))))
(setq gaodu (cdr (assoc 43 (entget en2))))
(setq pt0 (cdr (assoc 10 (entget en2))))
(setq bbox (vla-getboundingbox (vlax-ename->vla-object en2) 'p1 'p2))
(setq p1 (vlax-safearray->list p1)
p2 (vlax-safearray->list p2)
)
(if (< (- (car pt0) (car p2)) 0)
(setq p2 (list (+ (car p1) kuandu) (cadr p2)))
(setq p2 (list (- (car p1) kuandu) (cadr p2)))
)
(if (> (- (cadr pt0) (cadr p1)) 0)
(setq p1 (list (car p1) (- (cadr p2) gaodu)))
(setq p1 (list (car p1) (+ (cadr p2) gaodu)))
)
(setq midpt (mapcar
'(lambda (a b)
(* 0.5 (+ a b))
)
p1
p2
)
)
(setq pt-dis2 (list (trans midpt 0 1) (abs (distance p1 p2))))
);_结束
((or
(= ty "TEXT")
(= ty "ATTRIB")
)
(setq box (textbox ent4)
ang4 (cdr (assoc 50 ent4))
ls (mapcar
'(lambda (a b)
(* 0.5 (+ a b))
)
(car box)
(cadr box)
)
pt4 (cdr (assoc 10 ent4))
);_结束setq
(setq pt-dis2 (list (trans (polar pt4 (+ ang4 (angle '(0 0) ls)) (distance '(0 0) ls)) 0 1) (abs (distance
(car box)
(cadr box)
)
)
)
)
);_结束
);_结束cond
pt-dis2
);_结束defun_ffg-txt-mid-ptlong
;;;主程序开始
(vl-load-com)
(setvar "cmdecho" 0)
(command ".undo" "be")
(defun *error* (msg)
(if oos
(setvar "osmode" oos)
);_结束if
(setvar "cmdecho" 1)
);_结束error
(setq oos (getvar "osmode"))
(setvar "osmode" 0)
(setq ss (ssget '((0 . "TEXT,MTEXT,TCH_TEXT,TCH_MTEXT,ATTRIB")))
n 0
date1 (getvar "millisecs")
)
(while (setq en (ssname ss n))
(setq ty (cdr (assoc 0 (entget en))))
(setq pt-dis (ffg-txt-mid-ptlong en)
dis (cadr pt-dis);文字对角线距离
)
(setq k 1)
(setq ptm (trans (car pt-dis) 0 1))
(while (and
(null (setq disn (car (ffg-near-point-line ptm (* 0.5 pi) (* k dis)))))
(< k 20);根据实际表格，适当修改一下这个k最大值20，这里是最大20倍文字宽度。
)
(setq k (* 1.5 k));逐渐增大k值，循环尝试文字长度的多少倍能碰到表格边框
)
(setq k 1)
(while (and
(null (setq diss (car (ffg-near-point-line ptm (* 1.5 pi) (* k dis)))))
(< k 20);根据实际表格，适当修改一下这个k最大值20
)
(setq k (* 1.5 k))
)
(setq k 1)
(while (and
(null (setq dise (car (ffg-near-point-line ptm 0.0 (* k dis)))))
(< k 20);根据实际表格，适当修改一下这个k最大值20
)
(setq k (* 1.5 k))
)
(setq k 1)
(while (and
(null (setq disw (car (ffg-near-point-line ptm pi (* k dis)))))
(< k 20);根据实际表格，适当修改一下这个k最大值20
)
(setq k (* 1.5 k))
)
(if (and
disn
diss
)
(setq yy (* 0.5 (- disn diss)))
(setq yy 0)
);_结束if
(if (and
dise
disw
)
(setq xx (* 0.5 (- dise disw)))
(setq xx 0)
);_结束if
(if (not (= 0 xx yy))
(vla-move (vlax-ename->vla-object en) (vlax-3d-point ptm) (vlax-3d-point (list (+ (car ptm) xx) (+ (cadr ptm) yy))));vla-move比move快10倍
)
(setq n (1+ n))
);_结束while
(setq time (- (getvar "millisecs") date1))
(princ (strcat "\n耗时\"" (rtos (/ time 1000.000) 2 3) "\"秒,平均速度: " (rtos (/ (* (sslength ss) 1000.0) time) 2 0)
" 个/秒."
)
)
(setvar "osmode" oos)
(command ".undo" "e")
(setvar "cmdecho" 1)
(princ)
);_结束defun
http://bbs.mjtd.com/forum.php?mo ... =2&extra=#pid853170
很好，这次不用开盲盒。纯支持了~
罕见的没收费系列
本帖最后由 zhoupeng220 于 2025-12-5 15:09 编辑
源码,支持一波。
感谢分享，辛苦了
感谢分享，！！！
不会使用 不知道使用场景
试用了一下，报错，语法错误和有缺陷