文字动态对齐线（直线、多段线、曲线化的多段线、spl线）
看到论坛里的这篇帖子http://bbs.mjtd.com/thread-91313-1-1.html，里面有文字或属性动态对齐于曲线，感觉挺有意思，就自己也写了个；测试环境：AutoCAD2008
代码内还有一个判断单行文字四个角点的子函数，目前测试，在任意坐标系下可用
支持对象：单行文字，直线/多段线/曲线化的多段线/spl线
操作：w向上，s向下，a输入指定偏移距离
本帖最后由 尘缘一生 于 2018-7-27 07:30 编辑
yangchao2005090 发表于 2018-7-26 11:50
你好，能否加一个复制功能，复制然后平行线
这个简单，不过，移动文字再加上拷贝，有现实意义吗？怎么个画图目的这是?，请看下面修改代码：
(defun c:X-ROT-MOV-COPY(/ *error* getTextRectangBoxPointList pointRotate
pointMove get_AngleAndPtecho os text
textptlist curve temptext h p1 UpsideDown
UpsideDownLastk angleandpt
)
(vl-load-com)
(command "undo" "be")
(setq echo (getvar "cmdecho"))
(setq os (getvar "osmode"))
(setvar "cmdecho" 0)
(setvar "osmode" 0)
;;;错误处理函数
(defun *error* (msg)
(iftemptext
(entdel temptext)
)
(setvar "cmdecho" echo)
(setvar "osmode" os)
(princ)
)
;;;
;;;以下是子函数
;;;
;;;获取单行文字矩形外框点（在UCS下的外框点），返回点列表，依次左下、右下、右上、左上
;;;text为单行文字图元名称
(defun getTextRectangBoxPointList (text / pt1 pt2 pt3 pt4 basepoint ang)
(if(equal "TEXT" (cdr (assoc 0 (entget text))))
(progn
(setq pt1 (car (textbox (entget text)))
pt3 (cadr (textbox (entget text)))
pt2 (list (car pt3) (cadr pt1) 0)
pt4 (list (car pt1) (cadr pt3) 0)
)
(setq basepoint(cdr (assoc 10 (entget text)))
ang(cdr (assoc 50 (entget text)))
)
(mapcar
'trans
(mapcar
'(lambda (ropt basepoint ang z)
(pointMove (pointRotate ropt '(0 0 0) ang z) basepoint)
)
(list pt1 pt2 pt3 pt4)
(list basepoint basepoint basepoint basepoint)
(list ang ang ang ang)
(list (caddr basepoint)
(caddr basepoint)
(caddr basepoint)
(caddr basepoint)
)
)
(list text text text text)
'(1 1 1 1)
)
)
nil
)
)
;;;平面一点ropt绕basepoint逆时针旋转ang弧度得到的新点,
;;;并将得到的新点纵坐标改为z
(defun pointRotate (ropt basepoint ang z)
(list (+ (-(* (- (car ropt) (car basepoint)) (cos ang))
(* (- (cadr ropt) (cadr basepoint)) (sin ang))
)
(car basepoint)
)
(+ (+(* (- (car ropt) (car basepoint)) (sin ang))
(* (- (cadr ropt) (cadr basepoint)) (cos ang))
)
(cadr basepoint)
)
z
)
)
;;;返回点mopt根据向量vec移动后得到的新点
(defun pointMove (mopt vec)
(list (+ (car mopt) (car vec))
(+ (cadr mopt) (cadr vec))
(+ (caddr mopt) (caddr vec))
)
)
;;;
;;;根据ucs点坐标获取直线或者多段线的角度，该角度为世界坐标系角度
;;;pt为ucs坐标系的坐标点
;;;
(defun get_AngleAndPt(curve pt)
(setq curveobj (vlax-ename->vla-object curve))
(setq
closept (vlax-curve-getClosestPointTo curveobj (trans pt 1 0))
)
(setq param (vlax-curve-getParamAtPoint curveobj closept))
(list (angle closept
(mapcar '+
closept
(vlax-curve-getFirstDeriv curveobj param)
)
)
closept
)
)
;;;
;;;以下是主代码
;;;
(setq text (entsel "\n选取文字:"))
(if (setq textptlist (getTextRectangBoxPointList (car text)))
(progn
(if
(member
(cdr
(assoc
0
(entget
(car (setq
curve (entsel "\n选取曲线(直线/多段线/样条曲线):")
)
)
)
)
)
'("LINE" "LWPOLYLINE" "POLYLINE" "SPLINE")
)
(progn
(entmake
(list
(cons 0 "TEXT")
(cons 1 (cdr (assoc 1 (entget (car text)))))
(cons 10 '(0 0 0))
(cons 11 (cadr curve))
(cons 40 (cdr (assoc 40 (entget (car text)))))
(cons 50 (car (get_AngleAndPt (car curve) (cadr curve))))
(cons 72 1)
(cons 73 2)
)
)
(setq temptext (entlast))
(setq h (* (getvar "DIMSCALE") 8.0)
UpsideDown nil
UpsideDownLastnil
)
(while (/= 3 (car (setq k (grread T))))
(if (= 5 (car k))
(progn
(setq angleandpt (get_AngleAndPt (car curve) (cadr k)))
(if
(> (* (sin (car angleandpt)) (cos (car angleandpt)))
0
)
(progn
(if (> (car (trans (cadr k) 1 0))
(car (cadr angleandpt))
)
(setq UpsideDownLast UpsideDown
UpsideDown T
)
(setq UpsideDownLast UpsideDown
UpsideDown nil
)
)
)
(progn
(if (>= (car (trans (cadr k) 1 0))
(car (cadr angleandpt))
)
(setq UpsideDownLast UpsideDown
UpsideDown nil
)
(setq UpsideDownLast UpsideDown
UpsideDown T
)
)
)
)
(if UpsideDown
(progn
(entmod (subst (cons 71 7)
(assoc 71 (entget temptext))
(entget temptext)
)
)
)
(progn
(entmod (subst (cons 71 0)
(assoc 71 (entget temptext))
(entget temptext)
)
)
)
)
(if (/= UpsideDown UpsideDownLast)
(setq h (- h))
)
(setq angleandpt
(subst
(polar
(cadr angleandpt)
(+ (car angleandpt) (/ pi 2))
(* (* 0.1 h)
(cdr (assoc 40 (entget (car text))))
)
)
(cadr angleandpt)
angleandpt
)
)
(entmod (subst(cons 11 (cadr angleandpt))
(assoc 11 (entget temptext))
(subst (cons 50 (car angleandpt))
(assoc 50 (entget temptext))
(entget temptext)
)
)
)
)
)
)
(entdel temptext)
(setq angleandpt (get_AngleAndPt (car curve) (cadr k)))
(if (> (* (sin (car angleandpt)) (cos (car angleandpt))) 0)
(progn
(if
(> (car (trans (cadr k) 1 0)) (car (cadr angleandpt)))
(setqUpsideDownLast UpsideDown
UpsideDown T
)
(setqUpsideDownLast UpsideDown
UpsideDown nil
)
)
)
(progn
(if
(>= (car (trans (cadr k) 1 0)) (car (cadr angleandpt)))
(setqUpsideDownLast UpsideDown
UpsideDown nil
)
(setqUpsideDownLast UpsideDown
UpsideDown T
)
)
)
)
(if UpsideDown
(progn
(entmod (subst (cons 71 7)
(assoc 71 (entget (car text)))
(entget (car text))
)
)
)
(progn
(entmod (subst (cons 71 0)
(assoc 71 (entget (car text)))
(entget (car text))
)
)
)
)
(if (/= UpsideDown UpsideDownLast)
(setq h (- h))
)
(setq angleandpt
(subst
(polar (cadr angleandpt)
(+ (car angleandpt) (/ pi 2))
(* (* 0.1 h)
(cdr (assoc 40 (entget (car text))))
)
)
(cadr angleandpt)
angleandpt
)
)
(entmod
(subst (cons 73 2)
(assoc 73 (entget (car text)))
(subst (cons 72 1)
(assoc 72 (entget (car text)))
(subst (cons 11 (cadr angleandpt))
(assoc 11 (entget (car text)))
(subst (cons 50 (car angleandpt))
(assoc 50 (entget (car text)))
(entget (car text))
)
)
)
)
)
(setq p1 (nth 1 (grread 5))) ;;;;; 取得最近鼠标点
(command "copy" text "" p1 pause"") ;;;;;;拷贝文字并移动定位
)
(progn
(princ "\n没有选取合适的曲线(直线/多段线/样条曲线)!")
)
)
)
(progn
(princ "\n没选取正确的单行文字!")
nil
)
)
(command "undo" "e")
(setvar "osmode" os)
(setvar "cmdecho" echo)
(princ "\n")
(princ )
)
;;;;(princ "\n******文字动态对齐曲线***By:且听风吟09***修改：尘缘一生***命令：x-rot-mov-copy******")
对这个问题，我再啰嗦下，我认为，当你画图时候，你想移动平齐与曲线，就不可能目的是拷贝在曲线，这是2个不同目的的操作，应该构造不同的命令，我极其反对，一个命令里加开关那种写法，因为，这影响画图速度，多了按键选择，假如你目的就是这样的命令，那么上面代码再修改下，加个开关就是了.
我提的问题，还得我来修改？没有明白我得意思的？
下面发上代码：
(defun c:x-rot-mov (/ *error* getTextRectangBoxPointList pointRotate
pointMove get_AngleAndPtecho os text
textptlist curve temptext h UpsideDown
UpsideDownLastk angleandpt
)
(vl-load-com)
(command "undo" "be")
(setq echo (getvar "cmdecho"))
(setq os (getvar "osmode"))
(setvar "cmdecho" 0)
(setvar "osmode" 0)
;;;错误处理函数
(defun *error* (msg)
(iftemptext
(entdel temptext)
)
(setvar "cmdecho" echo)
(setvar "osmode" os)
(princ)
)
;;;
;;;以下是子函数
;;;
;;;获取单行文字矩形外框点（在UCS下的外框点），返回点列表，依次左下、右下、右上、左上
;;;text为单行文字图元名称
(defun getTextRectangBoxPointList (text / pt1 pt2 pt3 pt4 basepoint ang)
(if(equal "TEXT" (cdr (assoc 0 (entget text))))
(progn
(setq pt1 (car (textbox (entget text)))
pt3 (cadr (textbox (entget text)))
pt2 (list (car pt3) (cadr pt1) 0)
pt4 (list (car pt1) (cadr pt3) 0)
)
(setq basepoint(cdr (assoc 10 (entget text)))
ang(cdr (assoc 50 (entget text)))
)
(mapcar
'trans
(mapcar
'(lambda (ropt basepoint ang z)
(pointMove (pointRotate ropt '(0 0 0) ang z) basepoint)
)
(list pt1 pt2 pt3 pt4)
(list basepoint basepoint basepoint basepoint)
(list ang ang ang ang)
(list (caddr basepoint)
(caddr basepoint)
(caddr basepoint)
(caddr basepoint)
)
)
(list text text text text)
'(1 1 1 1)
)
)
nil
)
)
;;;平面一点ropt绕basepoint逆时针旋转ang弧度得到的新点,
;;;并将得到的新点纵坐标改为z
(defun pointRotate (ropt basepoint ang z)
(list (+ (-(* (- (car ropt) (car basepoint)) (cos ang))
(* (- (cadr ropt) (cadr basepoint)) (sin ang))
)
(car basepoint)
)
(+ (+(* (- (car ropt) (car basepoint)) (sin ang))
(* (- (cadr ropt) (cadr basepoint)) (cos ang))
)
(cadr basepoint)
)
z
)
)
;;;返回点mopt根据向量vec移动后得到的新点
(defun pointMove (mopt vec)
(list (+ (car mopt) (car vec))
(+ (cadr mopt) (cadr vec))
(+ (caddr mopt) (caddr vec))
)
)
;;;
;;;根据ucs点坐标获取直线或者多段线的角度，该角度为世界坐标系角度
;;;pt为ucs坐标系的坐标点
;;;
(defun get_AngleAndPt(curve pt)
(setq curveobj (vlax-ename->vla-object curve))
(setq
closept (vlax-curve-getClosestPointTo curveobj (trans pt 1 0))
)
(setq param (vlax-curve-getParamAtPoint curveobj closept))
(list (angle closept
(mapcar '+
closept
(vlax-curve-getFirstDeriv curveobj param)
)
)
closept
)
)
;;;
;;;以下是主代码
;;;
(setq text (entsel "\n选取文字:"))
(if (setq textptlist (getTextRectangBoxPointList (car text)))
(progn
(if
(member
(cdr
(assoc
0
(entget
(car (setq
curve (entsel "\n选取曲线(直线/多段线/样条曲线):")
)
)
)
)
)
'("LINE" "LWPOLYLINE" "POLYLINE" "SPLINE")
)
(progn
(entmake
(list
(cons 0 "TEXT")
(cons 1 (cdr (assoc 1 (entget (car text)))))
(cons 10 '(0 0 0))
(cons 11 (cadr curve))
(cons 40 (cdr (assoc 40 (entget (car text)))))
(cons 50 (car (get_AngleAndPt (car curve) (cadr curve))))
(cons 72 1)
(cons 73 2)
)
)
(setq temptext (entlast))
(setq h (* (getvar "DIMSCALE") 8.0)
UpsideDown nil
UpsideDownLastnil
)
(while (/= 3 (car (setq k (grread T))))
(if (= 5 (car k))
(progn
(setq angleandpt (get_AngleAndPt (car curve) (cadr k)))
(if
(> (* (sin (car angleandpt)) (cos (car angleandpt)))
0
)
(progn
(if (> (car (trans (cadr k) 1 0))
(car (cadr angleandpt))
)
(setq UpsideDownLast UpsideDown
UpsideDown T
)
(setq UpsideDownLast UpsideDown
UpsideDown nil
)
)
)
(progn
(if (>= (car (trans (cadr k) 1 0))
(car (cadr angleandpt))
)
(setq UpsideDownLast UpsideDown
UpsideDown nil
)
(setq UpsideDownLast UpsideDown
UpsideDown T
)
)
)
)
(if UpsideDown
(progn
(entmod (subst (cons 71 7)
(assoc 71 (entget temptext))
(entget temptext)
)
)
)
(progn
(entmod (subst (cons 71 0)
(assoc 71 (entget temptext))
(entget temptext)
)
)
)
)
(if (/= UpsideDown UpsideDownLast)
(setq h (- h))
)
(setq angleandpt
(subst
(polar
(cadr angleandpt)
(+ (car angleandpt) (/ pi 2))
(* (* 0.1 h)
(cdr (assoc 40 (entget (car text))))
)
)
(cadr angleandpt)
angleandpt
)
)
(entmod (subst(cons 11 (cadr angleandpt))
(assoc 11 (entget temptext))
(subst (cons 50 (car angleandpt))
(assoc 50 (entget temptext))
(entget temptext)
)
)
)
)
)
)
(entdel temptext)
(setq angleandpt (get_AngleAndPt (car curve) (cadr k)))
(if (> (* (sin (car angleandpt)) (cos (car angleandpt))) 0)
(progn
(if
(> (car (trans (cadr k) 1 0)) (car (cadr angleandpt)))
(setqUpsideDownLast UpsideDown
UpsideDown T
)
(setqUpsideDownLast UpsideDown
UpsideDown nil
)
)
)
(progn
(if
(>= (car (trans (cadr k) 1 0)) (car (cadr angleandpt)))
(setqUpsideDownLast UpsideDown
UpsideDown nil
)
(setqUpsideDownLast UpsideDown
UpsideDown T
)
)
)
)
(if UpsideDown
(progn
(entmod (subst (cons 71 7)
(assoc 71 (entget (car text)))
(entget (car text))
)
)
)
(progn
(entmod (subst (cons 71 0)
(assoc 71 (entget (car text)))
(entget (car text))
)
)
)
)
(if (/= UpsideDown UpsideDownLast)
(setq h (- h))
)
(setq angleandpt
(subst
(polar (cadr angleandpt)
(+ (car angleandpt) (/ pi 2))
(* (* 0.1 h)
(cdr (assoc 40 (entget (car text))))
)
)
(cadr angleandpt)
angleandpt
)
)
(entmod
(subst (cons 73 2)
(assoc 73 (entget (car text)))
(subst (cons 72 1)
(assoc 72 (entget (car text)))
(subst (cons 11 (cadr angleandpt))
(assoc 11 (entget (car text)))
(subst (cons 50 (car angleandpt))
(assoc 50 (entget (car text)))
(entget (car text))
)
)
)
)
)
)
(progn
(princ "\n没有选取合适的曲线(直线/多段线/样条曲线)!")
)
)
)
(progn
(princ "\n没选取正确的单行文字!")
nil
)
)
(command "undo" "e")
(setvar "osmode" os)
(setvar "cmdecho" echo)
(princ "\n")
(princ )
)
;;;;(princ "\n******文字动态对齐曲线***By:且听风吟09***修改：尘缘一生***命令：x-rot-mov******")
希望这个程序修改一下，按键太多，直接文字齐线，且在线上距离1毫米空隙即可！
代码有点长啊 尘缘一生 发表于 2018-7-22 06:36
我提的问题，还得我来修改？没有明白我得意思的？
下面发上代码：
你好，能否加一个复制功能，复制然后平行线 感谢 尘缘一生 分享程序!!!!! 尘缘一生 发表于 2018-7-27 07:16
这个简单，不过，移动文字再加上拷贝，有现实意义吗？怎么个画图目的这是?，请看下面修改代码：
谢谢，这个好像不是想要的那种，是我没说清楚，平时比如有一个注释AA，需要把它复制到很多地方，然后与线平行，如果co复制完成后，还要一个一个的设置文字与线平行 yangchao2005090 发表于 2018-7-27 10:19
谢谢，这个好像不是想要的那种，是我没说清楚，平时比如有一个注释AA，需要把它复制到很多地方，然后与线 ...
谢谢，第一个lsp可以实现？ 新人学习中