求把不规则文字或数字对齐并居中到线段的lisp程序！求赐教

相信自己666

求把不规则文字或数字对齐并居中到线段,文字距离线段可选填间距或固定间距1.5左右，求大师赐教lisp程序，十分感谢！

pxr201419

相信自己666 发表于 2020-3-21 07:23
好的谢谢老师，最好可以框选文字2行文字批量对齐，这个就不用一个个选中了，感激!

已更新，这个是通用式的。当然，还是应你的需求写在下面
(defun c:tt2(/ olddyn ss i ent type_e line poend pomid ang s_text text potext height poinsert ang0)
   (defun lr(l_st)
      (- (apply '+ (mapcar '(lambda (x y)(* (car x)(cadr y))) l_st (append (cdr l_st) (list (car l_st)))))
         (apply '+ (mapcar '(lambda (x y)(* (car y)(cadr x))) l_st (append (cdr l_st) (list (car l_st)))))))
   (prompt "\n选择1根线和2个文字")
   (if (setq ss (ssget '((0 . "*polyline,Line,ARC,SPLINE,Text"))))
      (progn
         (setq i 0 s_text '() s_line '())
         (while (< i (sslength ss))
            (setq ent (ssname ss i) i (1+ i)
                  type_e (cdr (assoc 0 (entget ent))))
            (if (= type_e "TEXT")
               (setq s_text (cons ent s_text))
               (setq s_line (cons ent s_line))))
         (while (> (length s_text) 2);文字多于2个时处理
            (prompt "\n文字不能多于2个，请重新选择文字")
            (setq s_text '() i 0 ss (ssget '((0 . "TEXT"))))
            (while (< i (sslength ss))
               (setq s_text (cons (ssname ss i) s_text)
                     i (1+ i))))
         (if (/= (length s_line) 1);线段多于1条时处理
            (setq line (car(entsel "\n只能选择1条线段，请重新选择线段")))
            (setq line (car s_line)))
         (setq poend (vlax-curve-getendpoint line);线段终点
               pomid (vlax-curve-getpointatdist line (/ (vlax-curve-getdistatpoint line poend) 2));线段中点
               ang (angle '(0 0) (vlax-curve-getfirstderiv line (vlax-curve-getParamAtPoint line pomid))));中点处的切线角度
         (while (and poend pomid ang s_text)
            (setq text (car s_text) s_text (cdr s_text))
            (if (= (cdr (assoc 0 (entget text))) "TEXT")
               (progn
                  (setq potext (cdr (assoc 10 (entget text)));文字插入点
                        height (cdr (assoc 40 (entget text))));文字高度
                  (if (> (lr (list pomid poend potext)) 0)
                     (setq poinsert (polar pomid (+ ang (/ pi 2)) height));文字在线段左边时
                     (setq poinsert (polar pomid (- ang (/ pi 2)) height)));文字在线段右边时
                  (if (and (> ang (/ pi 2)) (< ang (* 1.5 pi)))(setq ang0 (+ ang pi)) (setq ang0 ang));保证文字转角在1 4象限
                  (if (= ang0 (* 1.5 pi)) (setq ang0 (/ pi 2)));线段垂直时使文字朝向左边
                  (vlax-put (vlax-ename->vla-object text) 'Alignment 4);置文字对齐方式为中间
                  (vlax-put (vlax-ename->vla-object text) 'Rotation ang0);置文字角度
                  (vlax-put (vlax-ename->vla-object text) 'TextAlignmentPoint poinsert))))));置文字新的对齐点
   (princ))

uualice

发错版块了

laiyuming

好像有这个插件，论坛搜搜

pxr201419

(defun c:tt()
   (defun lr(l_st)
      (- (apply '+ (mapcar '(lambda (x y)(* (car x)(cadr y))) l_st (append (cdr l_st) (list (car l_st)))))
         (apply '+ (mapcar '(lambda (x y)(* (car y)(cadr x))) l_st (append (cdr l_st) (list (car l_st)))))))
   (setq olddyn (getvar "DYNMODE"))
   (setvar "DYNMODE" 1)
   (cond ((and (setq text (car(entsel "\n选取文字")))
               (setq line (car(entsel "\n选取线段")))
               (= (cdr (assoc 0 (entget text))) "TEXT")
               (member (cdr (assoc 0 (entget line))) '("LINE" "SPLINE" "ARC" "POLYLINE" "LWPOLYLINE")))
          (setq potext (cdr (assoc 10 (entget text)))
                height (cdr (assoc 40 (entget text)))
                poend (vlax-curve-getendpoint line)
                pomid (vlax-curve-getpointatdist line (/ (vlax-curve-getdistatpoint line poend) 2))
                ang (angle '(0 0) (vlax-curve-getfirstderiv line (vlax-curve-getParamAtPoint line pomid))))
          (if (> (lr (list pomid poend potext)) 0)
             (setq poinsert (polar pomid (+ ang (/ pi 2)) height))
             (setq poinsert (polar pomid (- ang (/ pi 2)) height)))
          (if (and (> ang (/ pi 2)) (< ang (* 1.5 pi)))(setq ang (+ ang pi)))          (vlax-put (vlax-ename->vla-object text) 'Alignment 4)
          (vlax-put (vlax-ename->vla-object text) 'Rotation ang)
          (vlax-put (vlax-ename->vla-object text) 'TextAlignmentPoint poinsert)))
   (setvar "DYNMODE" olddyn)
   (princ))

王鹏_pBZlo

pxr201419 发表于 2020-3-20 11:51
(defun c:tt()
   (defun lr(l_st)
      (- (apply '+ (mapcar '(lambda (x y)(* (car x)(cadr y))) l_s ...

注意有2个文字,需要分开到线的2侧

pxr201419

王老师，两边都有文字，分别对两个文字操作

zhystar

谢谢楼主分享

相信自己666

pxr201419 发表于 2020-3-20 13:04
王老师，两边都有文字，分别对两个文字操作

老师请问下这个程序您有吗？

相信自己666

laiyuming 发表于 2020-3-20 10:47
好像有这个插件，论坛搜搜

请问下知道不知道叫什么名称？谢谢

pxr201419

相信自己666 发表于 2020-3-20 22:02
请问下知道不知道叫什么名称？谢谢

你可以用关键词"对齐"搜索站内，很多贴子可参考

相信自己666

pxr201419 发表于 2020-3-20 22:23
程序已经写在上面了，加载后运行命令tt。你可以用关键词"对齐"搜索站内，很多贴子可参考

上面这个程序我试过了，只能用做把文字调整到直线上方，而直线下文字的文字也是调到上方，不是这种效果？还请老师赐教，十分感谢！

chrive

学习了！跟着受益

pxr201419

相信自己666 发表于 2020-3-20 22:29
上面这个程序我试过了，只能用做把文字调整到直线上方，而直线下文字的文字也是调到上方，不是这种效果？ ...

试了下，有不行的情况，修改后再发你

相信自己666

pxr201419 发表于 2020-3-20 22:38
试了下，有不行的情况，修改后再发你

好的谢谢老师，最好可以框选文字2行文字批量对齐，这个就不用一个个选中了，感激!