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

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 hudu1 jux_ang )
(setq hudu1 (+ jux_ang (* 0.5 pi)))
)
)
((WCMATCH(cdr(assoc 0 s11))"CIRCLE,SPLINE,ELLIPSE,XLINE")(setq hudu1 0 ))
(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 "" p1 pause)
)
(
(and
(and e1 e2)
(> (LENGTH ee)2)
)
(command "_.rotate" e1 "" point_e1 (- jiaodu2 jiaodu1 jiaodu3))
(command "_.MOVE" e1 "" point_e1 pause)
)
(t(command "_.rotate" e1 "" point_e1 (- jiaodu2 jiaodu1 ))
(command "_.MOVE" e1 "" point_e1 pause)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(princ)
)

;;物体齐线 来自明经高手：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 hudu1  jux_ang ) 
                  (setq hudu1  (+ jux_ang (* 0.5 pi))) 
    ) 
   ) 
             
        ((WCMATCH(cdr(assoc 0 s11))"CIRCLE,SPLINE,ELLIPSE,XLINE")(setq hudu1  0 )) 
  (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 ""  p1  pause) 
    ) 
    ( 
      (and 
           (and e1 e2) 
             (> (LENGTH ee)2) 
      ) 
           (command "_.rotate" e1 "" point_e1 (- jiaodu2 jiaodu1 jiaodu3))   
           (command  "_.MOVE" e1 ""  point_e1  pause) 
    ) 
    (t(command "_.rotate" e1 "" point_e1 (- jiaodu2 jiaodu1 ))   
      (command  "_.MOVE" e1 ""  point_e1  pause) 
           ) 
   
  ) 
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
  (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)
)

;;;拷贝文字随线角度 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

十年前的程序，插眼

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

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

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

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

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

baiyier1112 发表于 2013-4-20 17:29
万分感谢，现在版主的这个程序，可以支持块中图元及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

做个记号哈哈

账号		自动登录	找回密码
密码			注册

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

本帖子中包含更多资源

点评

相关帖子

点评

点评