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

wudechao

注册 发表于 2019-9-29 08:03
处理好了之后的代码还是不能识别pline

我修改正了，见修改后的代码。

wudechao

;再次修改，缩小scsz搜索范围，加快速度。排除斜线,vla-move比move快10倍
(defun c:wzjz (/ *error* oos en ss n ptm disn diss dise disw date1 xx yy pt-dis dis)
(defun ffg-snearlin (pt ang scsz / scsz ss3 m en3 ent3 ty ent2 ptj lst ang1);增加scsz参数，缩小选择范围
  (vl-load-com)
  (setq ss3 (ssget "f" (list pt (polar pt ang scsz)) '((0 . "LINE,LWPOLYLINE,POLYLINE")))
        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);355~360之间的角度设置为0,否则无法判断比如359.99度与0度是否相等
      (setq ang1 (* 2 pi))
     )
     (setq ang1 (rem ang1 (* 2 pi)))
     (if (equal ang1 ang 0.087266);误差5度
      (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)
  (setq ent4 (entget en2)
        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 (polar pt4 (+ ang4 (angle '(0 0) ls)) (distance '(0 0) ls)) (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,TCH_TEXT,ATTRIB")))
       n 0
       date1 (getvar "millisecs")
)
(while (setq en (ssname ss n))
  (setq pt-dis (ffg-txtmpt en))
  (setq ptm (trans (car pt-dis) 0 1)
        dis (cadr pt-dis)
        dise (ffg-snearlin ptm 0.0 (* 2 dis))
        disn (ffg-snearlin ptm (* 0.5 pi) (* 1 dis))
        disw (ffg-snearlin ptm (* 1.0 pi) (* 2 dis))
        diss (ffg-snearlin ptm (* 1.5 pi) (* 1 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))))
  );vla-move比move快10倍
  (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)
)

烟盒迷唇

你这个会出现参数类型错误：二维/三维点

wudechao

烟盒迷唇 发表于 2019-11-16 20:14
你这个会出现参数类型错误：二维/三维点

你根据实际表格，适当修改一下这个dis的倍数，这个距离如果太大，速度慢，距离太小，可能会找不到表格的边。
        dise (ffg-snearlin ptm 0.0 (* 1 dis))
        disn (ffg-snearlin ptm (* 0.5 pi) (* 3 dis))
        disw (ffg-snearlin ptm (* 1.0 pi) (* 1 dis))
        diss (ffg-snearlin ptm (* 1.5 pi) (* 3 dis))

烟盒迷唇

wudechao 发表于 2019-11-16 20:23
你根据实际表格，适当修改一下这个dis的倍数，这个距离如果太大，速度慢，距离太小，可能会找不到表格的 ...

不是这个DIS的问题吧，是提示这句话有问题：(setq ang1 (angle pt ptj))，二维/三维点

wudechao

烟盒迷唇 发表于 2019-11-16 20:33
不是这个DIS的问题吧，是提示这句话有问题：(setq ang1 (angle pt ptj))，二维/三维点

我的cad2014 win7 x64系统。我的没有问题。你的图可能是天正的格式吧？或者你的CAD不是完整版本，精简版本。

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)
)

zj20190405

wudechao 发表于 2019-9-26 18:19
用填充的找中点，速度太慢。院长的代码简练，佩服，不过执行效率低。测试520个字，院长的用了27秒。我下面 ...

大佬不支持多行文字

zj20190405

wudechao 发表于 2019-11-16 23:21
；文字表格秒居中,终结版本（经多次测试，比填充方式找中点约快215倍）
(defun c:wzjz (/ *error* oos en  ...

大佬能不能麻烦添加支持多行文字

wudechao

zj20190405 发表于 2019-12-22 23:05
大佬能不能麻烦添加支持多行文字

(setq ss (ssget '((0 . "TEXT,MTEXT,TCH_TEXT,ATTRIB")))