为什么最近用的文字居中lisp在cad2014中不能用了

alpha223334

大神们帮忙看看，文字居中的lisp在cad2014中不能用了
如下:
;;;文字定点在直线方格中心位置
(defun c:WZzJZ (/ en ptm)
;;;从一个点求到某个方向最近直线的距离
  (defun snearlin (pt ang / scsz ss n en pt1 pt2 ptj lst)
    (setq scsz (* (getvar "viewsize"))
   ss   (ssget "f" (list pt (polar pt ang scsz)) '((0 . "LINE")))
    )
    (if ss
      (progn
(setq n 0)
(while (setq en (ssname ss n))
   (setq ent (entget en)
  pt1 (trans (cdr (assoc 10 ent)) 0 1)
  pt2 (trans (cdr (assoc 11 ent)) 0 1)
  ptj (inters pt (polar pt ang 1.0) pt1 pt2 nil)
  lst (cons (list (distance pt ptj) en) lst)
  n   (1+ n)
   )
)    ; while
(apply 'min (mapcar 'car lst))
      )
    )
  )
;;;   求文字的中心点
  (defun txtmpt (en / ent box ls pt ang)
    (setq ent (entget en)
   box (textbox ent)
   ang (cdr (assoc 50 ent))
   ls  (mapcar '(lambda (a b) (* 0.5 (+ a b)))
        (car box)
        (cadr box)
       )
   pt  (cdr (assoc 10 ent))
    )
    (polar pt (+ ang (angle '(0 0) ls)) (distance '(0 0) ls))
  )     ; defun
;;; main
  (command "undo" "begin")
  (setq ss (ssget '((0 . "TEXT")))
n  0
  )
  (while (setq en (ssname ss n))
    (setq ptm  (trans (txtmpt en) 0 1)
   disn (snearlin ptm (* 0.5 pi))
   diss (snearlin ptm (* 1.5 pi))
   dise (snearlin ptm 0.0)
   disw (snearlin ptm pi)
    )
    (if (and disn diss)
      (setq yy (* 0.5 (- disn diss)))
      (setq yy 0)
    )
    (if (and dise disw)
      (setq xx (* 0.5 (- dise disw)))
      (setq xx 0)
    )
    (or (= 0 xx yy)
(command "move" en "" "non" (list xx yy) "")
    )
    (setq n (1+ n))
  )
  (command "undo" "end")
  (princ)
)

xyp1964

1. ;; tt(文字定点在直线方格中心位置)
   
2. (defun c:tt ()
   
3.   ;; 文字中心点
   
4.   (defun txtmpt        (s1 / en box p10 p1)
   
5.     (setq en  (entget s1)
   
6.           box (textbox en)
   
7.           p10 (cdr (assoc 10 en))
   
8.           p1  (mapcar '(lambda (x y) (* (+ x y) 0.5))
   
9.                       (car box)
   
10.                       (cadr box)
    
11.               )
    
12.     )
    
13.     (mapcar '(lambda (x y) (+ x y)) p10 p1)
    
14.   )
    
15.   (command "undo" "begin")
    
16.   (setq        ss (ssget '((0 . "TEXT")))
    
17.         n  -1
    
18.   )
    
19.   (while (setq s1 (ssname ss (setq n (1+ n))))
    
20.     (setq ptm (trans (txtmpt s1) 0 1))
    
21.     (bpoly ptm)
    
22.     (setq s2  (entlast)
    
23.           ptn (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget s2))
    
24.           ptn (mapcar 'cdr ptn)
    
25.           pt  (mapcar '(lambda (x y) (* (+ x y) 0.5))
    
26.                       (car ptn)
    
27.                       (caddr ptn)
    
28.               )
    
29.     )
    
30.     (entdel s2)
    
31.     (command "move" s1 "" "non" ptm "non" pt)
    
32.   )
    
33.   (command "undo" "end")
    
34.   (princ)
    
35. )

;; tt(文字定点在直线方格中心位置)<br /> (defun c:tt ()<br />   ;; 文字中心点<br />   (defun txtmpt        (s1 / en box p10 p1)<br />     (setq en  (entget s1)<br />           box (textbox en)<br />           p10 (cdr (assoc 10 en))<br />           p1  (mapcar '(lambda (x y) (* (+ x y) 0.5))<br />                       (car box)<br />                       (cadr box)<br />               )<br />     )<br />     (mapcar '(lambda (x y) (+ x y)) p10 p1)<br />   )<br />   (command "undo" "begin")<br />   (setq        ss (ssget '((0 . "TEXT")))<br />         n  -1<br />   )<br />   (while (setq s1 (ssname ss (setq n (1+ n))))<br />     (setq ptm (trans (txtmpt s1) 0 1))<br />     (bpoly ptm)<br />     (setq s2  (entlast)<br />           ptn (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget s2))<br />           ptn (mapcar 'cdr ptn)<br />           pt  (mapcar '(lambda (x y) (* (+ x y) 0.5))<br />                       (car ptn)<br />                       (caddr ptn)<br />               )<br />     )<br />     (entdel s2)<br />     (command "move" s1 "" "non" ptm "non" pt)<br />   )<br />   (command "undo" "end")<br />   (princ)<br /> )

wudechao

;另外一种方法表格居中（填充判断版），缺点：表格必须封闭（前面那个是交叉线判断，速度快，且表格不需要封闭），这个速度比前面交叉线判断那个wzjz慢很多。优点：前面那个wzjz可能dis倍数问题，交叉线没有和表格相交，可能文字移动不了，这个可以，两个程序互补。建议：优先用前面那个，个别不行，才有这个。论坛某位大师的代码，我增加并修正了MTEXT，TCH_TEXT,TCH_MTEXT。
(defun c:wzjz2 (/ err)
(vl-load-com)
(setvar "cmdecho" 0)
(command ".undo" "be")
(defun algion (msg / ss lst i vlalst boxlst cor1 cor2 findboxpt newboxpt en1 en enlst date1 ty kuandu gaodu pt0)
  (princ msg)
  (setq ss (ssget '((0 . "TEXT,MTEXT,TCH_TEXT,TCH_MTEXT,ATTRIB"))))
  (setq lst nil)
  (setq i 0)
  (setq date1 (getvar "millisecs"))
  (repeat (sslength ss)
   (setq lst (cons (ssname ss i) lst))
   (setq i (1+ i))
  )
  (setq vlalst (mapcar
        'vlax-ename->vla-object
        lst
           )
  )
  (setq boxlst (mapcar
        '(lambda (x / cor1 cor2)
          (vla-getboundingbox x 'cor1 'cor2)
          (setq ty (vlax-get-property x 'objectname))
          (if (= ty "AcDbMText")
           (progn
            (setq x (vlax-vla-object->ename x))
            (setq kuandu (cdr (assoc 42 (entget x))))
            (setq gaodu (cdr (assoc 43 (entget x))))
            (setq pt0 (cdr (assoc 10 (entget x))))
            (setq cor1 (safearray-value cor1)
              cor2 (safearray-value cor2)
            )
            (if (< (- (car pt0) (car cor2)) 0)
             (setq cor2 (list (+ (car pt0) kuandu) (cadr pt0)))
             (setq cor2 (list (- (car pt0) kuandu) (cadr pt0)))
            )
            (if (> (- (cadr pt0) (cadr cor1)) 0)
             (setq cor1 (list (car pt0) (- (cadr pt0) gaodu)))
             (setq cor1 (list (car pt0) (+ (cadr pt0) gaodu)))
            )
            (setq x (vlax-ename->vla-object x))
            (list cor1 cor2)
           )
           (list (vlax-safearray->list cor1) (vlax-safearray->list cor2))
          )
         )
        vlalst
           )
  )
  (setq findboxpt (mapcar
           '(lambda (x)
             (polar (car x) (angle (car x) (cadr x)) (/ (distance (car x) (cadr x)) 2.0))
            )
           boxlst
          )
  )
  (setq newboxpt (mapcar
          '(lambda (x)
            (setq en1 (entlast))
            (vl-cmdf "_boundary" "a" "i" "n" "n" "" x "")
            (setq en (entlast))
            (if (not (equal en1 en))
             (progn
              (setq enlst (entget en))
              (setq lst (vl-remove-if-not '(lambda (y)
                            (= (car y) 10)
                           ) enlst
                )
              )
              (setq cor1 (vl-remove 10 (car lst))
                cor2 (vl-remove 10 (nth 2 lst))
              )
              (entdel en)
              (polar cor1 (angle cor1 cor2) (/ (distance cor1 cor2) 2.0))
             )
            )
           )
          findboxpt
         )
  )
  (mapcar
   '(lambda (x y y2)
     (vla-move x (vlax-3d-point y) (vlax-3d-point y2))
    )
   vlalst
   findboxpt
   newboxpt
  )
  (princ (strcat "耗时\"" (rtos (/ (- (getvar "millisecs") date1) 1000.000) 2 3) "\"秒"))
)
(setq err (vl-catch-all-apply 'algion (list "\n请选择文字: ")))
(command ".undo" "e")
(setvar "cmdecho" 1)
(princ)
)

wudechao

；文字表格秒居中（交叉线判断版）,终结版本（经多次测试，比填充方式找中点约快215倍,2020.2.18修改 ffg-txtmpt函数，支持mtext和TCH_mtext，引进变量zg目的是加快处理表格速度，根据实际表格，适当修改一下这个dis的倍数）
(defun c:wzjz (/ *error* oos en ss n ptm disn diss dise disw date1 xx yy pt-dis dis zg)
(defun ffg-snearlin (pt ang scsz / scsz ss3 m en3 ent3 ty ent2 ptj lst ang1)
  (vl-load-com)
  (setq ss3 (ssget "f" (list pt (polar pt ang scsz)) '((0 . "LINE,LWPOLYLINE,POLYLINE") (8 . "~DEFPOINTS")))
        lst nil
  )
  (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)
      )
      (progn
       (setq ptj (trans (vlax-curve-getclosestpointto en3 (trans pt 1 0) t) 0 1))
      )
     )
     (setq ang1 (angle pt ptj))
     (if (equal ang1 (* 2 pi) 0.087266)
      (setq ang1 (* 2 pi))
     )
     (setq ang1 (rem ang1 (* 2 pi)))
     (if (equal ang1 ang 0.087266)
      (setq lst (cons (list (distance pt ptj) en3) lst))
     )
     (setq m (1+ m))
    )
    (apply
     'min
     (mapcar
      'car
      lst
     )
    )
   )
  )
)
  (defun ffg-txtmpt (en2 / ent4 box ls pt4 ang4 pt-dis2 ty p1 p2 kuandu gaodu pt0)
    (setq ent4 (entget en2))
    (setq ty (cdr (assoc 0 (entget en2))))
    (cond
      ((= ty "TCH_MTEXT")
    (vla-getboundingbox (vlax-ename->vla-object en2) 'p1 'p2)
    (setq p1 (safearray-value p1)
          p2 (safearray-value p2)
    )
    (setq midpt (polar p1 (angle p1 p2) (* 0.5 (distance 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))))
    (vla-getboundingbox (vlax-ename->vla-object en2) 'p1 'p2)
    (setq p1 (safearray-value p1)
          p2 (safearray-value p2)
    )
    (if (< (- (car pt0) (car p2)) 0)
      (setq p2 (list (+ (car pt0) kuandu) (cadr pt0)))
      (setq p2 (list (- (car pt0) kuandu) (cadr pt0)))
    )
    (if (> (- (cadr pt0) (cadr p1)) 0)
      (setq p1 (list (car pt0) (- (cadr pt0) gaodu)))
      (setq p1 (list (car pt0) (+ (cadr pt0) gaodu)))
    )
    (setq midpt (polar p1 (angle p1 p2) (* 0.5 (distance p1 p2))))
    (setq pt-dis2 (list (trans midpt 0 1) (abs (distance p1 p2))))
      )
      ((or
     (= ty "TEXT")
     (= ty "TCH_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 pt-dis2 (list (trans (polar pt4 (+ ang4 (angle '(0 0) ls)) (distance '(0 0) ls)) 0 1) (abs (distance (car box)
                                                           (cadr box)
                                                     )
                                                    )
              )
    )
      )
    )
  )
(vl-load-com)
(setvar "cmdecho" 0)
(defun *error* (msg)
  (if oos
   (setvar "osmode" oos)
  )
  (setvar "cmdecho" 1)
)
(command "undo" "begin")
(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 pt-dis (ffg-txtmpt en)
        dis (cadr pt-dis);;文字对角线距离
        zg (/ dis (cdr (assoc 40 (entget en))));;约等于长宽比
  )
  (setq ptm (trans (car pt-dis) 0 1)
        disn (ffg-snearlin ptm (* 0.5 pi) dis)
        diss (ffg-snearlin ptm (* 1.5 pi) dis)
  )
  (if (>= zg 3.0);长宽比很大的字
   (progn
    (setq dise (ffg-snearlin ptm 0.0 (* 1.5 dis));根据实际表格，适当修改一下这个dis的倍数
          disw (ffg-snearlin ptm pi (* 1.5 dis));根据实际表格，适当修改一下这个dis的倍数
    )
   )
  )
  (if (and
       (>= zg 1.6);长宽比中等的字
       (< zg 3.0)
      )
   (progn
    (setq dise (ffg-snearlin ptm 0.0 (* 3 dis));根据实际表格，适当修改一下这个dis的倍数
          disw (ffg-snearlin ptm pi (* 3 dis));根据实际表格，适当修改一下这个dis的倍数
    )
   )
  )
  (if (< zg 1.6);长宽比小的字
   (progn
    (setq dise (ffg-snearlin ptm 0.0 (* 4 dis));根据实际表格，适当修改一下这个dis的倍数
          disw (ffg-snearlin ptm pi (* 4 dis));根据实际表格，适当修改一下这个dis的倍数
    )
   )
  )
  (if (and
       disn
       diss
      )
   (setq yy (* 0.5 (- disn diss)))
   (setq yy 0)
  )
  (if (and
       dise
       disw
      )
   (setq xx (* 0.5 (- dise disw)))
   (setq xx 0)
  )
  (or
   (= 0 xx yy)
   (vla-move (vlax-ename->vla-object en) (vlax-3d-point ptm) (vlax-3d-point (list (+ (car ptm) xx) (+ (cadr ptm) yy))))
  )
  (setq n (1+ n))
)
(princ (strcat "\n耗时\"" (rtos (/ (- (getvar "millisecs") date1) 1000.000) 2 3) "\"秒"))
(command "undo" "end")
(setvar "osmode" oos)
(setvar "cmdecho" 1)
(princ)
)

烟盒迷唇

不贴出来出错提示，谁帮你看那么长的代码噢

alpha223334

多谢院长！

paulpipi

wudechao

用填充的找中点，速度太慢。院长的代码简练，佩服，不过执行效率低。测试520个字，院长的用了27秒。我下面修改的用了10秒，如果是填充方式，16秒左右。
(defun c:wzjz (/ en ss n ptm disn diss dise disw date1 xx yy)
(defun snearlin (pt ang / scsz ss n en pt1 pt2 ptj lst)
  (setq scsz (* (getvar "viewsize"))
    ss (ssget "f" (list pt (polar pt ang scsz)) '((0 . "LINE,LWPOLYLINE,POLYLINE")))
    lst nil
  )
  (if ss
   (progn
    (setq n 0)
    (while (setq en (ssname ss n))
     (setq ent (entget en)
       ptj (trans (vlax-curve-getclosestpointto en (trans pt 1 0) t) 0 1)
       lst (cons (list (distance pt ptj) en) lst)
       n (1+ n)
     )
    )
    (apply
     'min
     (mapcar
      'car
      lst
     )
    )
   )
  )
)
(defun txtmpt (en / ent box ls pt ang)
  (setq ent (entget en)
    box (textbox ent)
    ang (cdr (assoc 50 ent))
    ls (mapcar
        '(lambda (a b)
          (* 0.5 (+ a b))
         )
        (car box)
        (cadr box)
       )
    pt (cdr (assoc 10 ent))
  )
  (polar pt (+ ang (angle '(0 0) ls)) (distance '(0 0) ls))
)
(vl-load-com)
(setvar "cmdecho" 0)
(command "undo" "begin")
(setq ss (ssget '((0 . "TEXT,TCH_TEXT,ATTRIB")))
       n 0
       date1 (getvar "millisecs")
)
(while (setq en (ssname ss n))
  (setq ptm (trans (txtmpt en) 0 1)
    disn (snearlin ptm (* 0.5 pi))
    diss (snearlin ptm (* 1.5 pi))
    dise (snearlin ptm 0.0)
    disw (snearlin ptm pi)
  )
  (if (and
       disn
       diss
      )
   (setq yy (* 0.5 (- disn diss)))
   (setq yy 0)
  )
  (if (and
       dise
       disw
      )
   (setq xx (* 0.5 (- dise disw)))
   (setq xx 0)
  )
  (or
   (= 0 xx yy)
   (command "move" en "" "non" (list xx yy) "")
  )
  (setq n (1+ n))
)
(princ (strcat "耗时\"" (rtos (/ (- (getvar "millisecs") date1) 1000.000) 2 3) "\"秒"))
(command "undo" "end")
(setvar "cmdecho" 1)
(princ)
)

wudechao

楼主的这个程序可能是多义线问题，不能处理多义线，我修改了一下代码，可以运行了。

alpha223334

wudechao 发表于 2019-9-26 18:23
楼主的这个程序可能是多义线问题，不能处理多义线，我修改了一下代码，可以运行了。

多谢 多谢，谢谢修复

注册

wudechao 发表于 2019-9-26 18:23
楼主的这个程序可能是多义线问题，不能处理多义线，我修改了一下代码，可以运行了。

处理好了之后的代码还是不能识别pline

wudechao

再次修改，这次完美了。多义线完全可以用。
(defun c:wzjz (/ *error* oos en ss n ptm disn diss dise disw date1 xx yy)
  (defun snearlin (pt ang / scsz ss n en ent ty ent2 ptj lst ang1)
   (vl-load-com)
    (setq scsz (getvar "viewsize")
          ss (ssget "f" (list pt (polar pt ang scsz)) '((0 . "LINE,LWPOLYLINE,POLYLINE")))
          lst nil
    )
    (if ss
      (progn
        (setq n 0)
        (while (setq en (ssname ss n))
          (setq ent (entget en)
                ty (assoc 0 ent)
          )
          (if (or
                (= "LWPOLYLINE" (cdr ty))
                (= "POLYLINE" (cdr ty))
              )
            (progn
              (entmake (list '(0 . "LINE") (cons 10 pt) (cons 11 (polar pt ang scsz))))
              (setq ent2 (entlast))
              (setq ptj (vlax-invoke (vlax-ename->vla-object en) 'intersectwith (vlax-ename->vla-object ent2) acextendnone))
              (entdel ent2)
            )
            (progn
              (setq ptj (trans (vlax-curve-getclosestpointto en (trans pt 1 0) t) 0 1))
            )
          )
          (setq lst (cons (list (distance pt ptj) en) lst))
          (setq n (1+ n))
        )
        (apply
          'min
          (mapcar
            'car
            lst
          )
        )
      )
    )
  )
  (defun txtmpt (en / ent box ls pt ang)
    (setq ent (entget en)
          box (textbox ent)
          ang (cdr (assoc 50 ent))
          ls (mapcar
               '(lambda (a b)
                  (* 0.5 (+ a b))
                )
               (car box)
               (cadr box)
             )
          pt (cdr (assoc 10 ent))
    )
    (polar pt (+ ang (angle '(0 0) ls)) (distance '(0 0) ls))
  )
  (vl-load-com)
  (setvar "cmdecho" 0)
  (defun *error* (msg)
    (if oos
      (setvar "osmode" oos)
    )
    (setvar "cmdecho" 1)
  )
  (command "undo" "begin")
  (setq oos (getvar "osmode"))
  (setvar "osmode" 0)
  (setq ss (ssget '((0 . "TEXT,TCH_TEXT,ATTRIB")))
        n 0
        date1 (getvar "millisecs")
  )
  (while (setq en (ssname ss n))
    (setq ptm (trans (txtmpt en) 0 1)
          ptm (txtmpt en)
          disn (snearlin ptm (* 0.5 pi))
          diss (snearlin ptm (* 1.5 pi))
          dise (snearlin ptm 0.0)
          disw (snearlin ptm pi)
    )
    (if (and
          disn
          diss
        )
      (setq yy (* 0.5 (- disn diss)))
      (setq yy 0)
    )
    (if (and
          dise
          disw
        )
      (setq xx (* 0.5 (- dise disw)))
      (setq xx 0)
    )
    (or
      (= 0 xx yy)
      (command "_.move" en "" "non" (list xx yy) "")
    )
    (setq n (1+ n))
  )
  (princ (strcat "\n耗时\"" (rtos (/ (- (getvar "millisecs") date1) 1000.000) 2 3) "\"秒"))
  (command "undo" "end")
  (setvar "osmode" oos)
  (setvar "cmdecho" 1)
  (princ)
)