如何改进，生成线上线下文字？

ou_y_x

原程序如下，点击生成平行于直线，并在直线上的文字；
如果希望文字在直线下，只需把 (setq p2 (polar p1 (+ (/ pi 2) ang) 50))  改成 (setq p2 (polar p1 (+ (/ pi 2) ang) -350)) ；

但我现在想实现的是：
有一对平行直线，距离不超过600（或某个值），
点击上直线，文字在直线上部；点击下直线，文字在直线下部；

不知道如何来判断所点击的直线，往上600的距离内，是否有与之平行的直线，以确定文字在直线上或下；
希望各位能指点一二。


(defun c:z(/ cm n1 p1 p2 s1 d1 d2 ang )
  (setq cm (getvar "cmdecho"))
  (setvar "cmdecho" 0 )
   (if (=(tblobjname "STYLE" "TSSD_Rein") nil)
        (progn
        (entmake (list '(0 . "STYLE")
                       '(100 . "AcDbSymbolTableRecord")
                       '(100 . "AcDbTextStyleTableRecord")
                       '(2 . "TSSD_Rein")
                       '(70 . 0)
                       '(40 . 0)
                       '(41 . 0)
                       '(3 . "tssdeng.shx")
                       '(4 . "hztxt.shx")))))
  (setq n1 (entsel "\n生成文字"))
  (setq p1 (osnap (cadr n1) "nea"))
  (setq s1 (entget (car n1)))
  (setq d1 (cdr (assoc 10 s1)))
  (setq d2 (cdr (assoc 11 s1)))
  (setq ang (angle d1 d2))
  (if (= (cdr (assoc 0 s1)) "LINE")
    (progn
    (if (and (> ang (+ (/ pi 2) 0.02)) (<= ang (+ (* pi 1.5) 0.02)))
    (setq ang(- ang pi)))
    (setq p2 (polar p1 (+ (/ pi 2) ang) 50))   
    (entmake (list
               (cons 0 "TEXT")
               (cons 100 "AcDbText")
               (cons 1 "2%%13218")
               (cons 10 p2)
               (cons 40 300)
               (cons 50 ang)
               (cons 7 "TSSD_Rein")
               (cons 8 "TEXT-L")
               (cons 41 0.7)))))
(setvar "cmdecho" cm))

bai2000

不错的程序，顶一下 希望能框选生成相同的文字

edata

2. (defun c:tt(/ ss1 ss2 en1 ptx pt1 p11 e p10 ang ptup ptdn en2 e2 e11 e10 en3 e3 e310 e311 )
   
3.   
   
4.   (if (setq en1(entsel "\n选择直线:"))
   
5.     (progn
   
6.       (setq ptx(cadr en1))
   
7.       (setq pt1(osnap ptx "nea"))
   
8.       (setq e(entget (car en1)))
   
9.       (setq p10(cdr(assoc 10 e))
   
10.             p11(cdr(assoc 11 e))
    
11.             en1h(cdr(assoc 5 e))
    
12.             ang (angle p10 p11))
    
13.       (setq ptup(polar pt1 (+ ang (* pi 0.5)) 240)
    
14.             ptdn(polar pt1 (+ ang (* pi 1.5)) 240))
    
15.       (command "_.zoom" "non" ptup "non" ptdn)
    
16.       (setq ss1(ssget "c" pt1 ptup '((0 . "line"))))
    
17.       (setq ss2(ssget "c" pt1 ptdn '((0 . "line"))))
    
18.       (princ"aa")
    
19.       (princ (sslength ss1))
    
20.       (princ"cc")
    
21.       (princ (sslength ss2))
    
22.       (while (setq en2(ssname ss1 0))
    
23.         (setq e2(entget en2))
    
24.         (if (/= (cdr(assoc 5 e2)) en1h)
    
25.           (progn
    
26.         
    
27.         (setq e10 (cdr(assoc 10 e2))
    
28.               e11 (cdr(assoc 11 e2)))
    
29.         (and (= (inters p10 p11 e10 e11 nil) nil)(princ"up_par"))
    
30.         ))
    
31.         (setq ss1 (ssdel en2 ss1))
    
32.         )
    
33.       (while (setq en3(ssname ss2 0))
    
34.         (setq e3(entget en3))
    
35.         (if (/= (cdr(assoc 5 e3)) en1h)
    
36.           (progn
    
37.         
    
38.         (setq e310 (cdr(assoc 10 e3))
    
39.               e311 (cdr(assoc 11 e3)))
    
40.         (and (= (inters p10 p11 e310 e311 nil)nil)(princ"dn_par"))
    
41.         ))
    
42.         (setq ss2 (ssdel en3 ss2))
    
43.         )
    
44.   
    
45.   (command "_.zoom" "P")
    
46.       ))
    
47.   (princ)
    
48. )

(defun c:tt(/ ss1 ss2 en1 ptx pt1 p11 e p10 ang ptup ptdn en2 e2 e11 e10 en3 e3 e310 e311 )<br />   <br />   (if (setq en1(entsel "\n选择直线:"))<br />     (progn<br />       (setq ptx(cadr en1))<br />       (setq pt1(osnap ptx "nea"))<br />       (setq e(entget (car en1)))<br />       (setq p10(cdr(assoc 10 e))<br />             p11(cdr(assoc 11 e))<br />             en1h(cdr(assoc 5 e))<br />             ang (angle p10 p11))<br />       (setq ptup(polar pt1 (+ ang (* pi 0.5)) 240)<br />             ptdn(polar pt1 (+ ang (* pi 1.5)) 240))<br />       (command "_.zoom" "non" ptup "non" ptdn)<br />       (setq ss1(ssget "c" pt1 ptup '((0 . "line"))))<br />       (setq ss2(ssget "c" pt1 ptdn '((0 . "line"))))<br />       (princ"aa")<br />       (princ (sslength ss1))<br />       (princ"cc")<br />       (princ (sslength ss2))<br />       (while (setq en2(ssname ss1 0))<br />         (setq e2(entget en2))<br />         (if (/= (cdr(assoc 5 e2)) en1h)<br />           (progn<br />         <br />         (setq e10 (cdr(assoc 10 e2))<br />               e11 (cdr(assoc 11 e2)))<br />         (and (= (inters p10 p11 e10 e11 nil) nil)(princ"up_par"))<br />         ))<br />         (setq ss1 (ssdel en2 ss1))<br />         )<br />       (while (setq en3(ssname ss2 0))<br />         (setq e3(entget en3))<br />         (if (/= (cdr(assoc 5 e3)) en1h)<br />           (progn<br />         <br />         (setq e310 (cdr(assoc 10 e3))<br />               e311 (cdr(assoc 11 e3)))<br />         (and (= (inters p10 p11 e310 e311 nil)nil)(princ"dn_par"))<br />         ))<br />         (setq ss2 (ssdel en3 ss2))<br />         )<br />   <br />   (command "_.zoom" "P")<br />       ))<br />   (princ)<br /> )

未整理，，思路是取得当前直线上的点的时候，计算该点固定距离上下点，通过zoom缩放，使之可见，然后用ssget的c参数活得该距离的图元，如果有且平行的直线，执行文字位置设置。

ZZXXQQ

2. (defun c:z(/ cm n1 p1 p2 s1 d1 d2 ang )
   
3.   (setq cm (getvar "cmdecho"))
   
4.   (setvar "cmdecho" 0 )
   
5.   (if (=(tblobjname "STYLE" "TSSD_Rein") nil) (progn
   
6.    (entmake
   
7.     (list
   
8.      '(0 . "STYLE")
   
9.      '(100 . "AcDbSymbolTableRecord")
   
10.      '(100 . "AcDbTextStyleTableRecord")
    
11.      '(2 . "TSSD_Rein")
    
12.      '(70 . 0)
    
13.      '(40 . 0)
    
14.      '(41 . 0)
    
15.      '(3 . "tssdeng.shx")
    
16.      '(4 . "hztxt.shx")
    
17.     )
    
18.    )
    
19.   ))
    
20.   (setq n1 (entsel "\n生成文字"))
    
21.   (setq p0 (cadr n1))
    
22.   (setq p1 (osnap p0 "nea"))
    
23.   (setq ang1 (angle p1 p0))
    
24.   (setq s1 (entget (car n1)))
    
25.   (setq d1 (cdr (assoc 10 s1)))
    
26.   (setq d2 (cdr (assoc 11 s1)))
    
27.   (setq ang (angle d1 d2))
    
28.   (if (= (cdr (assoc 0 s1)) "LINE") (progn
    
29.    (if (and (> ang (+ (/ pi 2) 0.02)) (<= ang (+ (* pi 1.5) 0.02)))
    
30.    (setq ang(- ang pi)))
    
31.    (setq p2 (polar p1 ang1 200))
    
32.    (entmake
    
33.     (list
    
34.      (cons 0 "TEXT")
    
35.      '(100 . "AcDbEntity")
    
36.      (cons 8 "TEXT-L")
    
37.      (cons 100 "AcDbText")
    
38.      (cons 10 p2)
    
39.      (cons 40 300)
    
40.      (cons 1 "2%%13218")
    
41.      (cons 50 ang)
    
42.      (cons 41 0.7)
    
43.      (cons 7 "TSSD_Rein")
    
44.      '(71 . 0)
    
45.      '(72 . 4)
    
46.      (cons 11 p2)
    
47.      '(210 0.0 0.0 1.0)
    
48.      '(100 . "AcDbText")
    
49.      '(73 . 0)
    
50.     )
    
51.    )
    
52.   ))
    
53.   (setvar "cmdecho" cm)
    
54.   (princ)
    
55. )
    

(defun c:z(/ cm n1 p1 p2 s1 d1 d2 ang )<br />   (setq cm (getvar "cmdecho"))<br />   (setvar "cmdecho" 0 )<br />   (if (=(tblobjname "STYLE" "TSSD_Rein") nil) (progn<br />    (entmake<br />     (list<br />      '(0 . "STYLE") <br />      '(100 . "AcDbSymbolTableRecord") <br />      '(100 . "AcDbTextStyleTableRecord") <br />      '(2 . "TSSD_Rein")<br />      '(70 . 0)<br />      '(40 . 0)<br />      '(41 . 0) <br />      '(3 . "tssdeng.shx")<br />      '(4 . "hztxt.shx")<br />     )<br />    )<br />   ))<br />   (setq n1 (entsel "\n生成文字"))<br />   (setq p0 (cadr n1))<br />   (setq p1 (osnap p0 "nea"))<br />   (setq ang1 (angle p1 p0))<br />   (setq s1 (entget (car n1)))<br />   (setq d1 (cdr (assoc 10 s1)))<br />   (setq d2 (cdr (assoc 11 s1)))<br />   (setq ang (angle d1 d2))<br />   (if (= (cdr (assoc 0 s1)) "LINE") (progn<br />    (if (and (> ang (+ (/ pi 2) 0.02)) (<= ang (+ (* pi 1.5) 0.02)))<br />    (setq ang(- ang pi)))<br />    (setq p2 (polar p1 ang1 200))<br />    (entmake<br />     (list<br />      (cons 0 "TEXT")<br />      '(100 . "AcDbEntity")<br />      (cons 8 "TEXT-L")<br />      (cons 100 "AcDbText")<br />      (cons 10 p2)<br />      (cons 40 300)<br />      (cons 1 "2%%13218")<br />      (cons 50 ang)<br />      (cons 41 0.7)<br />      (cons 7 "TSSD_Rein")<br />      '(71 . 0)<br />      '(72 . 4)<br />      (cons 11 p2)<br />      '(210 0.0 0.0 1.0)<br />      '(100 . "AcDbText")<br />      '(73 . 0)<br />     )<br />    )<br />   ))<br />   (setvar "cmdecho" cm)<br />   (princ)<br /> )<br />

ou_y_x

ZZXXQQ 发表于 2013-12-17 08:24

版主厉害，
光标靠上则文字在上，光标靠下则文字在下。

ou_y_x

edata 发表于 2013-12-16 22:53
未整理，，思路是取得当前直线上的点的时候，计算该点固定距离上下点，通过zoom缩放，使之可见，然后用ssge ...

原来思路要这么复杂

adc

ZZXXQQ 发表于 2013-12-17 08:24

请问能不能让程序同时支持直线、多段线和块内的线

cable2004

最好能带上反应器

ZZXXQQ

adc 发表于 2013-12-30 20:12
请问能不能让程序同时支持直线、多段线和块内的线

其实可以支持一切可以取得最近点的实体。
去掉程序中有关直线部分即可。

清风明月名字

谢谢众位坛友代码分享！

adc

ZZXXQQ 发表于 2013-12-17 08:24

研究半天没弄懂，这样改了还是不行，请指教！
(defun c:z(/ cm n1 p1 p2 s1 d1 d2 ang )
  (setq cm (getvar "cmdecho"))
  (setvar "cmdecho" 0 )
  (if (=(tblobjname "STYLE" "TSSD_Rein") nil) (progn
   (entmake
    (list
     '(0 . "STYLE")
     '(100 . "AcDbSymbolTableRecord")
     '(100 . "AcDbTextStyleTableRecord")
     '(2 . "TSSD_Rein")
     '(70 . 0)
     '(40 . 0)
     '(41 . 0)
     '(3 . "tssdeng.shx")
     '(4 . "hztxt.shx")
    )
   )
  ))
  (setq n1 (entsel "\n生成文字"))
  (setq p0 (cadr n1))
  (setq p1 (osnap p0 "nea"))
  (setq ang1 (angle p1 p0))
  (setq s1 (entget (car n1)))
  (setq d1 (cdr (assoc 10 s1)))
  (setq d2 (cdr (assoc 11 s1)))
  (setq ang (angle d1 d2))
;;  (if (= (cdr (assoc 0 s1)) "LINE") (progn
   (if (and (> ang (+ (/ pi 2) 0.02)) (<= ang (+ (* pi 1.5) 0.02)))
   (setq ang(- ang pi)))
   (setq p2 (polar p1 ang1 200))
   (entmake
    (list
     (cons 0 "TEXT")
     '(100 . "AcDbEntity")
     (cons 8 "TEXT-L")
     (cons 100 "AcDbText")
     (cons 10 p2)
     (cons 40 300)
     (cons 1 "2%%13218")
     (cons 50 ang)
     (cons 41 0.7)
     (cons 7 "TSSD_Rein")
     '(71 . 0)
     '(72 . 4)
     (cons 11 p2)
     '(210 0.0 0.0 1.0)
     '(100 . "AcDbText")
     '(73 . 0)
    )
   )
;;  ))
  (setvar "cmdecho" cm)
  (princ)
)