社区 › AutoLISP/Visual LISP 编程技术 › 求个文字的复制并平行实体的程序

baiyier1112 发表于 2013-4-19 23:04:57

求个文字的复制并平行实体的程序

本帖最后由 baiyier1112 于 2013-4-20 17:49 编辑

求个lisp程序：如图，将文字连续复制到指定位置，并让文字与实体平行。
注意：复制后原文字要保留
（下面的动画示意是x_s_s_1做的）


拷贝文字随线角度，有高手x_s_s_1帮忙解决了，在此对其表示感谢。
由于这个功能我个人用的比较多，想要实现文字复制并平行实体，
即让这个功能适用于其他图元，包括曲线，块中线条等等。
我从明经找到了一个物体对齐的程序，不知能不能借鉴一下，现将两个程序的源代码附上，希望高手帮实现一下。

补充一下，我实际想要达到的效果：复制指定文字（如果能是实体会更加好），到指定线（包括曲线，块中线条等等）上的一点，并与该线平行，该命令可以连续操作。
实际操作效果类似与上面的第二个图片（第二个程序没有复制的功能，希望能补充上复制的功能。即：将第二个程序增加连续复制的效果。）
期待！！！！（第一个图片是第一个程序的效果。第二个图片是第二个程序的效果）


;;物体齐线 来自明经高手：yjr111

(defun c:yxpq(/ e1 e2 ee s11 s22 point_e1 vla_e1 vla_e2 dxf_10 p1 jux_ang e1_ang1 e1_ang2 hudu1
JIAODU1 HUDU2 JIAODU2 JIAODU3)
(vl-load-com)
(setvar "cmdecho" 0)
(setq e1 (car(setq ee(nentsel"\n 请选择要对齐的物体："))))
(setq s11 (entget e1))
(setq point_e1 (cdr(assoc 10 s11)))
(setq e2 (car(setq eee(entsel"\n 请选择物体要对齐的曲线"))))
(setq s22 (entget e2))

;;;;;;;;;;;取得点击点处最近的在实体或曲线的位置;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
       (setq vla_e1(vlax-ename->vla-object e1))
         (setq vla_e2(vlax-ename->vla-object e2))
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;      
(if(WCMATCH(cdr(assoc 0 s11))"*POLYLINE")
      (progn
      (setq p1(vlax-curve-getclosestpointto vla_e1 (cadr ee)));;;;;实体点击点若不在实体上，找到在实体上最近的点
             (SETQ dxf_10 (massoc 10 s11))
             (setq jux_ang(angle (nth 0 dxf_10)(nth 1 dxf_10)))
          (setq e1_ang1(angle (nth 0 dxf_10) p1))
         (setq e1_ang2(angle p1(nth 2 dxf_10) ) )
      (if(= e1_ang1 pi)(setq e1_ang1 0.0))
         (if(= e1_ang2 pi)(setq e1_ang2 0.0))
         (if(= jux_ang pi)(setq jux_ang 0.0))
       )
)   
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;取得待对齐的实体的旋转角度;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   (cond
      ((=(cdr(assoc 0 s11))"LINE")
            (setq hudu1
             (ATAN(/(-(cADdr(assoc 10 s11))(cADdr(assoc 11 s11)))(-(cAdr(assoc 10 s11))(cAdr(assoc 11 s11))))
      )
    )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;   
      ((WCMATCH(cdr(assoc 0 s11))"*POLYLINE,ARC")
   (if
      (or(equal jux_ANG e1_ang1 0.001)(equal jux_ANG e1_ang2 0.001))
                  (setq hudu1jux_ang )
                  (setq hudu1(+ jux_ang (* 0.5 pi)))
    )
   )
            
      ((WCMATCH(cdr(assoc 0 s11))"CIRCLE,SPLINE,ELLIPSE,XLINE")(setq hudu10 ))
(t (setq hudu1 (cdr(assoc 50 s11))))         
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



(SETQ JIAODU1 (* (/ HUDU1 PI)180))
;;;;;;;;;;;;;;;;;;;;;;;;;;返回关联表中相同组码保存的信息，明经lsp QQ群信息;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun massoc (code xlist / x nlist)
(setq nlist nil)
    (foreach x xlist
      (if (eq code (car x))
            (setq nlist (cons (cdr x) nlist))
      )
)
    (reverse nlist)
)



;;;;;;;;;;;;;;;;;;;;;;;;取得对齐直线的旋转角度;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(COND
((=(cdr(assoc 0 s22))"LINE")
    (if
      (/=
      (setq chushu1(-(cAdr(assoc 10 s22))(cAdr(assoc 11 s22)))
      )
      0)
                        (setq hudu2 (ATAN(/ (-(cADdr(assoc 10 s22))(cADdr(assoc 11 s22))) chushu1)))
                        (setq hudu2 (* 0.5 pi))
    )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;      
       ((WCMATCH(cdr(assoc 0 s22))"*POLYLINE,ARC,SPLINE")
    (setq p2(vlax-curve-getclosestpointto vla_e2 (cadr eee)));;;;;曲线点击点若不在曲线上，找到在曲线上最近的点
                (setq p3
         (vlax-curve-getclosestpointto vla_e2
      (list
            (+(car p2)0.001)
          (+(cadr p2)0.001)
          (+(caddr p2)0.0)
      )
      )
    )
          (setq hudu2 (angle p2 p3))
   )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;      
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;                              


(SETQ JIAODU2 (* (/ HUDU2 PI)180))
;;;;;;;;;;;;;;旋转平移;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(IF (> (LENGTH ee)2)
    (PROGN (SETQ e1 (CAAR (REVERSE ee)))
                  (setq point_e1 (cdr(assoc 10 (ENTGET e1)))
                     jiaodu3 (*(/(cdr(assoc 50 (ENTGET e1)))PI)180)
      )
    )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    (cond
    (
      (and
      (and
               (and e1 e2)
               (< (LENGTH ee)3)
      )
             (WCMATCH(cdr(assoc 0 s11))"*POLYLINE")
         )
      (command "_.rotate" e1 "" p1 (- jiaodu2 jiaodu1))
      (command"_.MOVE" e1 ""p1pause)
    )
    (
      (and
         (and e1 e2)
             (> (LENGTH ee)2)
      )
         (command "_.rotate" e1 "" point_e1 (- jiaodu2 jiaodu1 jiaodu3))
         (command"_.MOVE" e1 ""point_e1pause)
    )
    (t(command "_.rotate" e1 "" point_e1 (- jiaodu2 jiaodu1 ))
      (command"_.MOVE" e1 ""point_e1pause)
         )

)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(princ)
)


;;;拷贝文字随线角度 by x_s_s_1@163.com
(vl-load-com)
(defun c:ctb (/ ent enl pt1 pt2 mid_pt ang)
;;;;;;;;;;;;;; ============================================================================
(defun emk_t (layer pt1 pt2 text ang n72 n73 h w sty /)
      (entmake (list '(0 . "text")
         '(100 . "AcDbEntity")
         (cons 8 layer)
         '(100 . "AcDbText")
         (cons 10 pt1)
         (cons 1 text)
         (cons 40 h)
         (cons 41 w)
         (cons 7 sty)
         (cons 72 n72)
      (cons 11 pt2)
         (cons 50 ang)
         (cons 73 n73)
         )
      )
   )
;;;;;;;;;;;;;; ============================================================================
   (setq ent (car (entsel "\n选择文字：")))
;;;;;;;;;;;;;; ============================================================================
   (if (= "TEXT" (cdr (assoc 0 (entget ent))))
      (progn
         (while (setq enl (entsel "\n选择对齐线："))
   (if (= "LINE" (cdr (assoc 0 (entget (car enl)))))
      (progn
      (setq pt1(cdr (assoc 10 (entget (car enl))))
         pt2(cdr (assoc 11 (entget (car enl))))
             mid_pt (vlax-curve-getClosestPointTo
               (vlax-ename->vla-object (car enl))
               (cadr enl)
                  )
      ang(angle pt1 pt2)
         )
         (if (and (> ang (* 0.5 pi)) (<= ang (* pi 1.5)))
            (setq ang (- ang pi))
         )
         (emk_t (cdr (assoc 8 (entget ent)))
            '(0 0 0)
            (polar mid_pt (+ ang (* 0.5 pi)) 100)
            (cdr (assoc 1 (entget ent)))
            ang
            1
            0
            (cdr (assoc 40 (entget ent)))
            (cdr (assoc 41 (entget ent)))
            (cdr (assoc 7 (entget ent)))
         )
      )
   )
         )
      )
)
;;;;;;;;;;;;;; ============================================================================            
(princ)
)

bai2000 发表于 2020-12-3 22:25:56

不错，刚找到这个lisp，那个老大能改改：能批量对齐于线中点更好

wline 发表于 2024-7-1 21:04:43

:lol十年前的程序，插眼

ZZXXQQ 发表于 2013-4-20 08:53:29

(defun c:ctb ()
(setvar "CMDECHO" 0)
(setq oldos (getvar "OSMODE"))
(setvar "OSMODE" 0)
(if (setq s1 (entsel "\n选择文字: ")) (progn
(setq en (car s1)
      txth (cdr(assoc 40 (entget en)))
      ptt (cdr(assoc 10 (entget en))))
(while (and (setq pt (getpoint "\n靠近线条一点: "))
            (setq p1 (osnap pt "near")))
   (setq ang (- (angle p1 pt) (/ pi 2)))
   (if (<= (* pi 0.67) ang (* pi 1.6667)) (setq ang (- ang pi)))
   (setq pt1 (polar p1 (+ ang (/ pi 2)) (/ txth 2)))
   (command "copy" en "" ptt pt1)
   (setq ent (entget (entlast)))
   (entmod (subst (cons 50 ang) (assoc 50 ent) ent))
)
))
(setvar "OSMODE" oldos)
(setvar "CMDECHO" 1)
(princ)
)

baiyier1112 发表于 2013-4-20 17:29:16

本帖最后由 baiyier1112 于 2013-4-20 17:55 编辑

ZZXXQQ 发表于 2013-4-20 08:53 http://bbs.mjtd.com/static/image/common/back.gif


万分感谢，现在版主的这个程序，可以支持块中图元及PL线了，希望版主继续出手改进。我在1楼补充了下希望达到的效果，期待版主的无私奉献

补充一下，我实际想要达到的效果：复制指定文字（如果能是实体会更加好），到指定线（包括曲线，块中线条等等）上的一点，并与该线平行，该命令可以连续操作。
实际操作效果类似与上面的第二个图片（第二个程序没有复制的功能，希望能补充上复制的功能。即：将第二个程序增加连续复制的效果。）
期待！！！！（第一个图片是第一个程序的效果。第二个图片是第二个程序的效果）

我对自己语言上的表达不清像版主表示歉意！
另外请教下：复制后的文字距离直线的距离是哪个语句设定的?
有没有办法使用本程序后不改变cad的捕捉设置？

baiyier1112 发表于 2013-4-21 09:13:34

baiyier1112 发表于 2013-4-20 17:29 static/image/common/back.gif
万分感谢，现在版主的这个程序，可以支持块中图元及PL线了，希望版主继续出手改进。我在1楼补充了 ...

多谢~~~~~~~~~~~~~~~~~~~~~

云中孤鹰 发表于 2013-4-21 10:54:50

挺不错的，多谢分享

朽木大师 发表于 2013-5-16 12:56:06

做个记号，以备用

yaokui25 发表于 2013-5-16 15:54:44

做个记号，以备用

完整武器 发表于 2013-5-17 00:40:43

很好用的程序 已备用

香田里浪人 发表于 2013-5-23 07:13:21

很好用的程序

edsion24 发表于 2013-7-21 15:37:37

做个记号 哈哈

查看完整版本: 求个文字的复制并平行实体的程序