文字居中（分组优化版,交叉线判断版），速度更快，希望大家重新下载！感谢wudechao

weimeng555

CAD2021测试，单个CAD文字，或者多个CAD文字，没实现居中效果，表格是多段线、或者直线围成的，居中效果没实现楼主截图的效果。。。

小毛草

注册线段不是能3维线，要Z轴归0才可以！

lxl217114

(setvar "DRAGMODE" 0)    ; 关闭拖动显示
这一行，建议大家自行删除一下，会影响画图的实时显示效果。

wudechao

；文字表格秒居中（交叉线判断版）,比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

小毛草

感谢，看改一下对齐方式，试下，能不能提高速度，现在就是太慢了！

小毛草

现在已经按上面的交叉线判断法修改，速度有一定的提升，请大家下新版！

fzlong

谢谢分享，收藏备用

dbx511

收藏备用。谢谢！

qwsss31

小毛草 发表于 2025-12-5 14:03
支持天正文字版，可以试下，未测试!

错误: no function definition: OBJ-TYPE