【高手请进】能否实现如下功能

illcyt

各位大神你们好，特别感谢你们的关注，我开门见山：
本人在平时绘图习惯于保持精确的尺寸绘图，但常常遇到如图下问题，都是一个个手画，工作比较繁琐，先向论坛大神们求助能否实现如下功能的lsp，本人不太会说感激的话，但是真心感谢在成功路上给予帮助的大神们！

Gu_xl

1. (defun c:tt (/ E P1 P2 SS PL FLAG)
   
2.   (princ "\n选择指定图层物体:")
   
3.   (if (and
   
4.         (setq e (ssget ":s"))
   
5.         (setq p1 (getpoint "\n画线第一点:"))
   
6.         (setq p2 (getpoint p1 "\n画线第二点:"))
   
7.       )
   
8.     (progn
   
9.       (setq ss
   
10.              (ssget "_F"
    
11.                     (list p1 p2)
    
12.                     (list (cons 0 "*line") (assoc 8 (entget (ssname e 0))))
    
13.              )
    
14.       )
    
15.       (if ss
    
16.         (progn
    
17.           (setq
    
18.             pl (mapcar '(lambda (x) (cadr (cadddr x))) (ssnamex ss))
    
19.           )
    
20.           (setq p1 (car pl) pl (cdr pl) flag t)
    
21.           (while pl
    
22.             (setq p2 (car pl) pl (cdr pl))
    
23.             (if flag
    
24.             (entmake
    
25.               (list '(0 . "line")
    
26.                     (cons 10 (polar p1 (angle p2 p1) 150))
    
27.                     (cons 11 (polar p2 (angle p1 p2) 150))
    
28.                     )
    
29.               )
    
30.               (entmake
    
31.               (list '(0 . "line")
    
32.                     (cons 10 (polar (polar p1 (* 0.5 pi) 100) (angle p2 p1) 150))
    
33.                     (cons 11 (polar (polar p2 (* 0.5 pi) 100) (angle p1 p2) 150))
    
34.                     )
    
35.               )
    
36.               )
    
37.             (setq p1 p2 flag (not flag))
    
38.             )
    
39.         )
    
40.       )
    
41.     )
    
42.   )
    
43.   (princ)
    
44. )
    

(defun c:tt (/ E P1 P2 SS PL FLAG)<br />   (princ "\n选择指定图层物体:")<br />   (if (and<br />         (setq e (ssget ":s"))<br />         (setq p1 (getpoint "\n画线第一点:"))<br />         (setq p2 (getpoint p1 "\n画线第二点:"))<br />       )<br />     (progn<br />       (setq ss<br />              (ssget "_F"<br />                     (list p1 p2)<br />                     (list (cons 0 "*line") (assoc 8 (entget (ssname e 0))))<br />              )<br />       )<br />       (if ss<br />         (progn<br />           (setq<br />             pl (mapcar '(lambda (x) (cadr (cadddr x))) (ssnamex ss))<br />           )<br />           (setq p1 (car pl) pl (cdr pl) flag t)<br />           (while pl<br />             (setq p2 (car pl) pl (cdr pl))<br />             (if flag<br />             (entmake<br />               (list '(0 . "line")<br />                     (cons 10 (polar p1 (angle p2 p1) 150))<br />                     (cons 11 (polar p2 (angle p1 p2) 150))<br />                     )<br />               )<br />               (entmake<br />               (list '(0 . "line")<br />                     (cons 10 (polar (polar p1 (* 0.5 pi) 100) (angle p2 p1) 150))<br />                     (cons 11 (polar (polar p2 (* 0.5 pi) 100) (angle p1 p2) 150))<br />                     )<br />               )<br />               )<br />             (setq p1 p2 flag (not flag))<br />             )<br />         )<br />       )<br />     )<br />   )<br />   (princ)<br /> )<br />

357785513

高呀,高呀.不错呀

illcyt

Gu_xl 发表于 2012-12-3 21:50

G版依旧犀利，这么快就给解决了，使用中发现一个小小的问题如图所示，就是指定直线为某线宽的多线时，偏移数值就会有些偏差，如果这个也能够解决，就完美了！

Gu_xl

illcyt 发表于 2012-12-4 08:39
G版依旧犀利，这么快就给解决了，使用中发现一个小小的问题如图所示，就是指定直线为某线宽的多线时，偏移 ...

1. (defun c:tt (/ E P1 P2 SS PL FLAG a b w1 w2)
   
2.   (princ "\n选择指定图层物体:")
   
3.   (if (and
   
4.         (setq e (ssget ":s"))
   
5.         (setq p1 (getpoint "\n画线第一点:"))
   
6.         (setq p2 (getpoint p1 "\n画线第二点:"))
   
7.       )
   
8.     (progn
   
9.       (setq ss
   
10.              (ssget "_F"
    
11.                     (list p1 p2)
    
12.                     (list (cons 0 "*line") (assoc 8 (entget (ssname e 0))))
    
13.              )
    
14.       )
    
15.       (if ss
    
16.         (progn
    
17.           (setq
    
18.             pl (mapcar '(lambda (x) (list (cadr x) (cadr (cadddr x)))) (ssnamex ss))
    
19.           )
    
20.           (setq a (car pl) pl (cdr pl) flag t)
    
21.           (while pl
    
22.             (setq p1 (cadr a) e1 (car a))
    
23.             (if (WCMATCH (cdr (assoc 0 (entget e1))) "*POLYLINE")
    
24.               (setq w1 (* 0.5 (vla-get-ConstantWidth (vlax-ename->vla-object e1))))
    
25.               (setq w1 0)
    
26.               )
    
27.             (setq b (car pl) pl (cdr pl))
    
28.             (setq p2 (cadr b) e2 (car b))
    
29.             (if (WCMATCH (cdr (assoc 0 (entget e2))) "*POLYLINE")
    
30.               (setq w2 (* 0.5 (vla-get-ConstantWidth (vlax-ename->vla-object e2))))
    
31.               (setq w2 0)
    
32.               )
    
33.             (if flag
    
34.             (entmake
    
35.               (list '(0 . "line")
    
36.                     (cons 10 (polar p1 (angle p2 p1) (+ w1 150)))
    
37.                     (cons 11 (polar p2 (angle p1 p2) (+ w2 150)))
    
38.                     )
    
39.               )
    
40.               (entmake
    
41.               (list '(0 . "line")
    
42.                     (cons 10 (polar (polar p1 (* 0.5 pi) 100) (angle p2 p1) (+ w1 150)))
    
43.                     (cons 11 (polar (polar p2 (* 0.5 pi) 100) (angle p1 p2) (+ w2 150)))
    
44.                     )
    
45.               )
    
46.               )
    
47.             (setq a b flag (not flag))
    
48.             )
    
49.         )
    
50.       )
    
51.     )
    
52.   )
    
53.   (princ)
    
54. )
    

(defun c:tt (/ E P1 P2 SS PL FLAG a b w1 w2)<br />   (princ "\n选择指定图层物体:")<br />   (if (and<br />         (setq e (ssget ":s"))<br />         (setq p1 (getpoint "\n画线第一点:"))<br />         (setq p2 (getpoint p1 "\n画线第二点:"))<br />       )<br />     (progn<br />       (setq ss<br />              (ssget "_F"<br />                     (list p1 p2)<br />                     (list (cons 0 "*line") (assoc 8 (entget (ssname e 0))))<br />              )<br />       )<br />       (if ss<br />         (progn<br />           (setq<br />             pl (mapcar '(lambda (x) (list (cadr x) (cadr (cadddr x)))) (ssnamex ss))<br />           )<br />           (setq a (car pl) pl (cdr pl) flag t)<br />           (while pl<br />             (setq p1 (cadr a) e1 (car a))<br />             (if (WCMATCH (cdr (assoc 0 (entget e1))) "*POLYLINE")<br />               (setq w1 (* 0.5 (vla-get-ConstantWidth (vlax-ename->vla-object e1))))<br />               (setq w1 0)<br />               )<br />             (setq b (car pl) pl (cdr pl))<br />             (setq p2 (cadr b) e2 (car b))<br />             (if (WCMATCH (cdr (assoc 0 (entget e2))) "*POLYLINE")<br />               (setq w2 (* 0.5 (vla-get-ConstantWidth (vlax-ename->vla-object e2))))<br />               (setq w2 0)<br />               )<br />             (if flag<br />             (entmake<br />               (list '(0 . "line")<br />                     (cons 10 (polar p1 (angle p2 p1) (+ w1 150)))<br />                     (cons 11 (polar p2 (angle p1 p2) (+ w2 150)))<br />                     )<br />               )<br />               (entmake<br />               (list '(0 . "line")<br />                     (cons 10 (polar (polar p1 (* 0.5 pi) 100) (angle p2 p1) (+ w1 150)))<br />                     (cons 11 (polar (polar p2 (* 0.5 pi) 100) (angle p1 p2) (+ w2 150)))<br />                     )<br />               )<br />               )<br />             (setq a b flag (not flag))<br />             )<br />         )<br />       )<br />     )<br />   )<br />   (princ)<br /> )<br />

illcyt

Gu_xl 发表于 2012-12-4 09:51

G版你好，在你给的源码基础上，实现了我上部的想法，于是在构思能否实现如图操作，请教了@革天明，提供了如下思路：
;;选择集->图元名表
   (defun ss->elst (ss / elst)
     (setq i 0)
     (repeat (sslength ss)
       (setq elst (cons (ssname ss i) elst)
            i         (1+ i)
       )
     )
     (reverse elst)
   )
   ;;两点的中点
   (defun mpt (mpt1 mpt2)
     (polar mpt1 (angle mpt1 mpt2) (/ (distance mpt1 mpt2) 2))
   )
   (setq        ss    (ssget '((8 . "CX砂面线")))
        sslst (ss->elst ss)
        ptlst (mapcar '(lambda (x / data p1 p2 dist p0)
                         (setq data (entget x))
                         (setq p1 (cdr (assoc 10 data)))
                         (setq p2 (cdr (assoc 11 data)))
                         (setq dist (distance p2 p1))
                         (setq p0 (mpt p1 p2))
                         (list p0
                               (polar p0 (* pi 0.5) dist)
                               (polar p0 (* pi 0.5) (* 1.5 dist))
                         )
                       )
                      sslst
              )
   )
   (setq i 0)
   (repeat (length ptlst)
     (setq n (nth i ptlst))
     (entmake (list '(0 . "LEADER")
                   '(100 . "AcDbEntity")
                   '(100 . "AcDbLeader")
                   (cons 10 (car n))
                   (cons 10 (cadr n))
                   (cons 10 (caddr n))
             )
     )
     (setq i (1+ i))
   )


可是我还不够完善，分别表现为不能够支持引出标注，特厚着脸皮再来请教你，如何能够实现和完善，谢谢