[LISP程序]：求可以将文字与线平行的lsp程序？

lml67919

求可以将文字与线平行的lsp程序？非常感谢！

viviczh

写了一个lisp程序，可以参考看看

2. 
   
3. (DEFUN C:RT (/              a               ent        ent1         et          lineangle
   
4.              linelist1               linelist2         linept1  linept2
   
5.              n              name     s
   
6.             )
   
7.   (setq s (ssget))
   
8.   (setq et (entget (car (entsel "\n选择角度线:"))))
   
9.   (setq linelist1 (assoc 10 et))
   
10.   (setq linelist2 (assoc 11 et))
    
11.   (setq linept1 (list (nth 1 linelist1) (nth 2 linelist1)))
    
12.   (setq linept2 (list (nth 1 linelist2) (nth 2 linelist2)))
    
13.   (setq lineangle (angle linept1 linept2))
    
14.   (if (< 1.57 lineangle 3.14)
    
15.     (setq lineangle (- lineangle 3.14))
    
16.   )
    
17.   (if (< 3.14 lineangle 4.71)
    
18.     (setq lineangle (- lineangle 3.14))
    
19.   )
    
20.   (setq n (sslength s))
    
21.   (setq a 1)
    
22.   (while (<= a n)
    
23.     (setq name (ssname s (- a 1)))
    
24.     (setq ent (entget name))
    
25.     (setq ent1 (subst (cons 50 lineangle) (assoc 50 ent) ent))
    
26.     (entmod ent1)
    
27.     (setq a (+ a 1))
    
28.   )
    
29. )

<br /> (DEFUN C:RT (/              a               ent        ent1         et          lineangle<br />              linelist1               linelist2         linept1  linept2<br />              n              name     s<br />             )<br />   (setq s (ssget))<br />   (setq et (entget (car (entsel "\n选择角度线:"))))<br />   (setq linelist1 (assoc 10 et))<br />   (setq linelist2 (assoc 11 et))<br />   (setq linept1 (list (nth 1 linelist1) (nth 2 linelist1)))<br />   (setq linept2 (list (nth 1 linelist2) (nth 2 linelist2)))<br />   (setq lineangle (angle linept1 linept2))<br />   (if (< 1.57 lineangle 3.14)<br />     (setq lineangle (- lineangle 3.14))<br />   )<br />   (if (< 3.14 lineangle 4.71)<br />     (setq lineangle (- lineangle 3.14))<br />   )<br />   (setq n (sslength s))<br />   (setq a 1)<br />   (while (<= a n)<br />     (setq name (ssname s (- a 1)))<br />     (setq ent (entget name))<br />     (setq ent1 (subst (cons 50 lineangle) (assoc 50 ent) ent))<br />     (entmod ent1)<br />     (setq a (+ a 1))<br />   )<br /> )

ysy419

不错，可以实现

purplebamboo

再加上选线的两头 一面是正 一面是反 就更加完善了

xiaoyue663

好东东，找了它好久啊

cy956

内部函数没贴。大意是选线，按线的切线方向定文字转角，再移到原来的文字中点位置（偷懒用move）

2. 
   
3. 
   
4. (defun c:wztj(/ A A1 E0 E1 E11 EN0 P1 PZX0 PZX1);;;文字同角;;
   
5.   (undo_begin)
   
6.   (mapcar 'setvar '("cmdecho""pickbox""aperture""osmode""blipmode") '(0 4 4 512 0))
   
7.   (setq e0(cy_entsel '((0 . "TEXT")) "\n选择要 与线同角 的文字:"))
   
8.   (if e0(progn
   
9.     (setq e1(cy_entsel '((0 . "*LINE,CIRCLE,ARC,ELLIPSE,TEXT")) "\n选择参照的线或曲线:"))
   
10.     (if e1(progn
    
11.       (setq e11(car e1) p1(osnap (cadr e1) "nea")
    
12.             a(cy_qd_jd e11 p1)
    
13.             a1(cy_txta a 1)
    
14.             en0(entget (car e0))pzx0(cy_textb_m en0)
    
15.             en0(subst (cons 50 a1)(assoc 50 en0)en0))
    
16.       (setq en0(entmod en0))
    
17.       (setq pzx1(cy_textb_m en0))
    
18.       (mapcar 'setvar '("pickbox""aperture""osmode") '(0 1 0))
    
19.       (command "move" (cdr (car en0)) "" pzx1 pzx0)
    
20.       (mapcar 'setvar '("pickbox""aperture""osmode") '(4 4 32))
    
21.     ) )
    
22.   ) )
    
23.   (mapcar 'setvar '("cmdecho""pickbox""aperture""osmode""blipmode") '(1 4 4 32 1))
    
24.   (undo_end)(princ)
    
25. )
    
26. 
    

<br /> <br /> (defun c:wztj(/ A A1 E0 E1 E11 EN0 P1 PZX0 PZX1);;;文字同角;;<br />   (undo_begin)<br />   (mapcar 'setvar '("cmdecho""pickbox""aperture""osmode""blipmode") '(0 4 4 512 0))<br />   (setq e0(cy_entsel '((0 . "TEXT")) "\n选择要 与线同角 的文字:"))<br />   (if e0(progn<br />     (setq e1(cy_entsel '((0 . "*LINE,CIRCLE,ARC,ELLIPSE,TEXT")) "\n选择参照的线或曲线:"))<br />     (if e1(progn<br />       (setq e11(car e1) p1(osnap (cadr e1) "nea")<br />             a(cy_qd_jd e11 p1)<br />             a1(cy_txta a 1)<br />             en0(entget (car e0))pzx0(cy_textb_m en0)<br />             en0(subst (cons 50 a1)(assoc 50 en0)en0))<br />       (setq en0(entmod en0))<br />       (setq pzx1(cy_textb_m en0))<br />       (mapcar 'setvar '("pickbox""aperture""osmode") '(0 1 0))<br />       (command "move" (cdr (car en0)) "" pzx1 pzx0)<br />       (mapcar 'setvar '("pickbox""aperture""osmode") '(4 4 32))<br />     ) )<br />   ) )<br />   (mapcar 'setvar '("cmdecho""pickbox""aperture""osmode""blipmode") '(1 4 4 32 1))<br />   (undo_end)(princ)<br /> )<br /> <br />

小九喜欢吃葡挞

还蛮不错的软件，谢谢楼主，如果能把实物也能平行于线的话那该多好啊

xxming

;文字与直线平行
(DEFUN C:test(/ LINEENT TEXTENT LINEANGLE PTS PTE)
(vl-load-com)
(SETQ LINEEN (ENTSEL"\n选择直线"))
(if (= (cdr(assoc 0 (entget(car lineen)))) "LWPOLYLINE")
(PROGN
(command "explode" (car lineen) "")
(alert "\n将多义线分解,请选择直线")
(SETQ LINEEN (ENTSEL"\n选择直线"))
(redraw (car lineen) 3)
(IF LINEEN
(PROGN
(SETQ LINEENT (ENTGET (CAR LINEEN)))
(SETQ PTS (cdr(assoc 10 LINEENT)))
(SETQ PTE (cdr(assoc 11 LINEENT)))
(SETQ LINEANGLE (ANGLE PTS PTE))
(SETQ TEXTEN (ENTSEL "\n选择文字"))
(redraw (car lineen) 4)
(IF TEXTEN
(PROGN
(setq obj (vlax-ename->vla-object (car texten)))
(vla-put-rotation obj LINEANGLE)
)))))
(progn
(redraw (car lineen) 3)
(SETQ LINEENT (ENTGET (CAR LINEEN)))
(SETQ PTS (cdr(assoc 10 LINEENT)))
(SETQ PTE (cdr(assoc 11 LINEENT)))
(SETQ LINEANGLE (ANGLE PTS PTE))
(SETQ TEXTEN (ENTSEL "\n选择文字"))
(redraw (car lineen) 4)
(IF TEXTEN
(PROGN
(setq obj (vlax-ename->vla-object (car texten)))
(vla-put-rotation obj LINEANGLE)
))))
(princ));DEFUN

eachy

注意对 LINEANGLE 进行"格式化" 使字的方向符合制图规范

adtt

这个程序不错哦.借用了..谢谢各位高手

xyz518mm

不错的文字平行程序有这程式真是不错

ynjzlzd

6楼的内部函数没贴,根本就无法使用吗,何不一齐贴出来.

hh222222

在70个小工具里有这个功能

zyhjg97

很好用

wawbt

在70个小工具里有这个功能.按线对齐,但几个人都是编的程序,在编程中才能不断提高自己啊