生成二维多段线？

树櫴希德

1. (defun vxs (e / i v lst ppp)
   
2.   (setq i 0)
   
3.   (while
   
4.     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
   
5.      (setq lst (cons v lst))
   
6.   )
   
7.   (setq ppp (reverse lst) )
   
8. (append (list(vlax-curve-getpointatparam e 0)) ppp )
   
9.   
   
10.   )
    
11. (vl-load-com)
    
12. ;(vla-AddPolyline (vxs(car(entsel))))   (vla-addlightweightpolyline (vxs(car(entsel))))
    
13. (setq plst nil)
    
14. (setq plst (vxs(car(entsel))) )
    
15. 
    
16. (setq plst1 (apply 'append
    
17.                    (append plst (list (car plst)))
    
18.             ) )
    
19. (setq points
    
20.        (vlax-make-safearray
    
21.          vlax-vbdouble
    
22.          (cons 0 (- (length plst1) 1))
    
23.        )
    
24. )
    
25. (vlax-safearray-fill points plst1)
    
26. 
    
27. 
    
28. (setq ms
    
29.        (vla-get-ModelSpace
    
30.          (vla-get-ActiveDocument
    
31.            (vlax-get-acad-object)
    
32.          )
    
33.        )
    
34. )
    
35. 
    
36. (vla-AddPolyline   ms    points   )
    
37. 
    

(defun vxs (e / i v lst ppp)<br />   (setq i 0)<br />   (while<br />     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))<br />      (setq lst (cons v lst))<br />   )<br />   (setq ppp (reverse lst) )<br /> (append (list(vlax-curve-getpointatparam e 0)) ppp )<br />   <br />   )<br /> (vl-load-com)<br /> ;(vla-AddPolyline (vxs(car(entsel))))   (vla-addlightweightpolyline (vxs(car(entsel))))<br /> (setq plst nil)<br /> (setq plst (vxs(car(entsel))) )<br /> <br /> (setq plst1 (apply 'append<br />                    (append plst (list (car plst)))<br />             ) )<br /> (setq points<br />        (vlax-make-safearray<br />          vlax-vbdouble<br />          (cons 0 (- (length plst1) 1))<br />        )<br /> )<br /> (vlax-safearray-fill points plst1)<br /> <br /> <br /> (setq ms<br />        (vla-get-ModelSpace<br />          (vla-get-ActiveDocument<br />            (vlax-get-acad-object)<br />          )<br />        )<br /> )<br /> <br /> (vla-AddPolyline   ms    points   )<br /> <br />

树櫴希德

1. ;求解二点距离子函数
   
2. (defun mdist(pt0 pt1 / opt tpt)
   
3. (setq x0 (nth 0 pt0) y0 (nth 1 pt0))
   
4. (setq x1 (nth 0 pt1) y1 (nth 1 pt1))
   
5. (setq dx (- x0 x1) dy (- y0 y1))
   
6. (setq xddist (sqrt (+ (* dx dx) (* dy dy))))
   
7. )
   
8. ;-----------------------------
   
9. 
   
10. (defun c:pladp( / addAn arcAn arcEP arcR arcSP cenPT code70 endpt
    
11.                   fwjCE fwjCM fwjCS fwjSE i ii j jiaJ layli laynam
    
12.                   midpt midptl npldat pldat repnum res sn ssp ssp1
    
13.                   sspt startp startpt strin syscmd tmpels totalp entlt entth entco)
    
14. (command "undo" "BE")
    
15. (setq syscmd (getvar "cmdecho"))
    
16. (setvar "cmdecho" 0)
    
17. (prompt "\n多义线孤线段加点:")
    
18. (setq sn (getreal "\n输入近似多段线的单位长度<1.0>: "))
    
19. (if (= sn nil) (setq sn 1.0))
    
20. (initget "1 2")
    
21. (setq res (getkword "\n    请选择转换方式：1 按图层/2 人为选择(缺省为2):"))
    
22. (if (= res nil) (setq res "2"))
    
23.   (cond ((= res "1")
    
24.        (setq laynam (getstring "\n    图层名："))
    
25.        (setq layli (cons 8 laynam))
    
26.        (setq ssp (ssget "X" (list (cons 8 laynam) (cons  0  "POLYLINE"))))
    
27.        (setq ssp1 (ssget "X" (list (cons 8 laynam) (cons  0  "LWPOLYLINE"))))
    
28.        (setq i 0)
    
29.        (repeat (sslength ssp1) (ssadd (ssname  ssp1 i) ssp) (setq i (1+ i))))
    
30.       ((= res "2")
    
31.        (prompt "\n    请选择需转换的实体(可窗选，自动过滤出多义线实体):")                                    
    
32.        (setq ssp (ssget '((-4 . "<OR") (0 . "LWPOLYLINE") (0 . "POLYLINE") (-4 . "OR>"))))
    
33.       )                                             
    
34.   );cond
    
35. (princ "\n        ...正在转换...")
    
36. (command "layer" "m" "df-point" "")
    
37. (command "ERASE" (ssget "x" '((8 . "df-point") (0 . "POINT"))))
    
38. (while ssp
    
39.       (setq i 0 )
    
40.       (repeat (sslength ssp)
    
41.          (setq  npldat nil chanyn nil j 0)
    
42.          (setq pldat (entget (ssname ssp i) '("*")))
    
43.          (print (cdr (assoc 5 pldat)))
    
44.          (setq code70 (cdr (assoc 70 pldat)))
    
45.          (while (and (< j (length pldat))  (= (cdr (assoc 0 pldat)) "LWPOLYLINE"))
    
46.               (if (= (car (nth j pldat)) 42) (/= (cdr (nth j pldat)) 0.0) (progn (setq chanyn T) (setq j (length pldat)))  )
    
47.           )
    
48.          (cond ( (and (= (cdr (assoc 0 pldat)) "LWPOLYLINE")  chanyn)
    
49.                 (setq startpt (assoc 10 pldat))
    
50.                 (setq endpt (assoc 10 (reverse pldat)))
    
51.                 (setq npldat nil)
    
52.                 (setq j 0 totalp 0)
    
53.                 (while (< j (length pldat))
    
54.                  (if (and (= (car (nth j pldat)) 10)  (= (car (nth (+ j 3) pldat)) 42) (/= (cdr (nth (+ j 3) pldat)) 0.0) )
    
55.                    (progn
    
56.                     (setq midptl (list (nth j pldat) '(40 . 0.0) '(41 . 0.0) '(42 . 0.0)))
    
57.                     (setq totalp (1+ totalp))
    
58.                     (setq npldat (append npldat midptl))
    
59.                     (setq arcSP (cdr (nth j pldat)))
    
60.                     (setq arcEP (cdr (nth (+ j 4) pldat)))                        
    
61.                     (if  (and (> (abs (- (/ code70 2.0) (fix (/ code70 2.0)))) 0.49) (= (car (nth (+ j 4) pldat)) 210))
    
62.                         (setq arcEP (cdr (assoc 10 pldat)))  );if
    
63.                     (setq arcAn (* (atan (cdr (nth (+ j 3) pldat))) 2))
    
64.                     (setq strin (/ (mdist arcSP arcEP) 2))
    
65.                     (setq arcR (/ strin (sin arcAn)))
    
66.                     (setq fwjSE (angle arcSP arcEP))
    
67.                     (setq cenPT (polar arcSP (+ fwjSE (- (/ pi 2.0) arcAn)) arcR))
    
68.                     (setq fwjCS (angle cenPT arcSP))
    
69.                     (setq fwjCE (angle cenPT arcEP))
    
70.                     (setq jiaJ (abs (- fwjCE fwjCS)))
    
71.                     (if (and (> fwjCE fwjCS) (< (cdr (nth (+ j 3) pldat)) 0)) (setq jiaj (- (* pi 2.0) jiaj)))
    
72.                     (if (and (< fwjCE fwjCS) (> (cdr (nth (+ j 3) pldat)) 0)) (setq jiaj (- (* pi 2.0) jiaj)))
    
73.                     (setq addAn  (/ sn arcR))
    
74.                     (setq fwjCM (+ fwjCS addAn))
    
75.                     (setq repnum (fix (abs (/ jiaj addAn))))                    
    
76.                     (if  (and (< (abs (- (/ code70 2.0) (fix (/ code70 2.0)))) 0.001) (= (car (nth (+ j 4) pldat)) 210))
    
77.                          (progn
    
78.                             (setq repnum 0)
    
79.                             (setq npldat (append npldat (list (nth j pldat))))
    
80.                             (setq totalp (1+ totalp))
    
81.                           )
    
82.                          (repeat repnum
    
83.                            (setq midpt (polar cenPT fwjCM (abs arcR)))
    
84.                            (setq midptl (list (cons '10 midpt) '(40 . 0.0) '(41 . 0.0) '(42 . 0.0)))
    
85.                            (setq totalp (1+ totalp))
    
86.                            (setq npldat (append npldat midptl))
    
87.                            (setq fwjCM (+ fwjCM addAn)));r
    
88.                      );if
    
89.                      (setq j (+ 3 j))
    
90.                    );pr
    
91.                  (progn (setq npldat (append npldat (list (nth j pldat))))
    
92.                  (if (= (car (nth j pldat)) 10) (setq totalp (1+ totalp))    ))
    
93.                  );if
    
94.                  (setq j (1+ j))
    
95.                 );wh
    
96.                 (setq npldat (subst  (cons 90 totalp) (assoc 90 npldat) npldat))
    
97.                 (entmod npldat)
    
98.                );cond-1
    
99.          ((= (cdr (assoc 0 pldat)) "POLYLINE")
    
100.            (if (or (= code70 2) (= code70 3) (= code70 4) (= code70 5)
     
101.                    (= code70 130) (= code70 131) (= code70 132) (= code70 133))
     
102.                    (progn      
     
103.            (getplp (ssname ssp i))
     
104.            ;(command "pedit" (ssname ssp i) "D" "")
     
105.            ;(setq tmpels (entget (ssname ssp i)))
     
106.            ;(setq startp (assoc 10 tmpels))
     
107.            ;(setq endpt (assoc 10 (reverse tmpels)))
     
108.            (setq startp (cons 10 (car plpt)))
     
109.            (setq endpt (cons 10 (last plpt)))
     
110.            (command "layer" "s" "df-point" "")
     
111.            (if (> (mdist (car plpt) (last plpt)) (* sn 2.0)) (command "measure" (ssname ssp i) sn) (command "measure" (ssname ssp i) (/ (mdist (car plpt) (last plpt)) 3.0)))           
     
112.            (setq sspt nil)
     
113.            (setq sspt (ssget "x" '((8 . "df-point") (0 . "POINT"))))
     
114.                    (if (= (setq entlt (cdr (assoc 6 pldat))) nil) (setq entlt "bylayer") )
     
115.                    (if (= (setq entth (cdr (assoc 39 pldat))) nil) (setq entth 0) )
     
116.                    (if (= (setq entco (cdr (assoc 62 pldat))) nil) (setq entco "bylayer") )
     
117.                    (command "clayer" (cdr (assoc 8 pldat)) "color" entco "celtype" entlt "thickness" entth)
     
118.                  (entmake pldat)
     
119.                  (setq ii (1- (sslength sspt)))
     
120.                  (if (< (abs (- (/ code70 2.0) (fix (/ code70 2.0)) ))  0.01) (entmake (list '(0 . "VERTEX") startp)))
     
121.                  (repeat (sslength sspt)
     
122.                          (setq tmpels (assoc 10 (entget (ssname sspt ii))))
     
123.                          (entmake (list '(0 . "VERTEX") tmpels))   
     
124.                          (setq ii (1- ii))    );r
     
125.                   (if (< (abs (- (/ code70 2.0) (fix (/ code70 2.0))))  0.01) (entmake (list '(0 . "VERTEX") endpt)))
     
126.                   (entmake (list '(0 . "SEQEND")))
     
127.                   (command "_.erase" sspt "")
     
128.                   (entdel  (ssname ssp i))
     
129.                   (command "pedit" (entlast) "d" "")
     
130.          ));pr;if                  
     
131.          );cond-2  
     
132.          );cond
     
133.       (setq i (1+ i))
     
134.       );r
     
135. (setq ssp nil)
     
136. );wh
     
137. ;(command "undo" "E")
     
138. (setvar "cmdecho" syscmd)
     
139. (princ)
     
140. )
     
141. 
     

;求解二点距离子函数<br /> (defun mdist(pt0 pt1 / opt tpt)<br /> (setq x0 (nth 0 pt0) y0 (nth 1 pt0))<br /> (setq x1 (nth 0 pt1) y1 (nth 1 pt1))<br /> (setq dx (- x0 x1) dy (- y0 y1))<br /> (setq xddist (sqrt (+ (* dx dx) (* dy dy))))<br /> )<br /> ;-----------------------------<br /> <br /> (defun c:pladp( / addAn arcAn arcEP arcR arcSP cenPT code70 endpt<br />                   fwjCE fwjCM fwjCS fwjSE i ii j jiaJ layli laynam<br />                   midpt midptl npldat pldat repnum res sn ssp ssp1<br />                   sspt startp startpt strin syscmd tmpels totalp entlt entth entco)<br /> (command "undo" "BE")<br /> (setq syscmd (getvar "cmdecho"))<br /> (setvar "cmdecho" 0)<br /> (prompt "\n多义线孤线段加点:")<br /> (setq sn (getreal "\n输入近似多段线的单位长度<1.0>: "))<br /> (if (= sn nil) (setq sn 1.0))<br /> (initget "1 2")<br /> (setq res (getkword "\n    请选择转换方式：1 按图层/2 人为选择(缺省为2):"))<br /> (if (= res nil) (setq res "2"))<br />   (cond ((= res "1")<br />        (setq laynam (getstring "\n    图层名："))<br />        (setq layli (cons 8 laynam))<br />        (setq ssp (ssget "X" (list (cons 8 laynam) (cons  0  "POLYLINE"))))<br />        (setq ssp1 (ssget "X" (list (cons 8 laynam) (cons  0  "LWPOLYLINE"))))<br />        (setq i 0)<br />        (repeat (sslength ssp1) (ssadd (ssname  ssp1 i) ssp) (setq i (1+ i))))<br />       ((= res "2")<br />        (prompt "\n    请选择需转换的实体(可窗选，自动过滤出多义线实体):")                                    <br />        (setq ssp (ssget '((-4 . "<OR") (0 . "LWPOLYLINE") (0 . "POLYLINE") (-4 . "OR>"))))<br />       )                                             <br />   );cond <br /> (princ "\n        ...正在转换...")<br /> (command "layer" "m" "df-point" "")<br /> (command "ERASE" (ssget "x" '((8 . "df-point") (0 . "POINT"))))<br /> (while ssp<br />       (setq i 0 )<br />       (repeat (sslength ssp)<br />          (setq  npldat nil chanyn nil j 0)<br />          (setq pldat (entget (ssname ssp i) '("*")))<br />          (print (cdr (assoc 5 pldat)))<br />          (setq code70 (cdr (assoc 70 pldat)))<br />          (while (and (< j (length pldat))  (= (cdr (assoc 0 pldat)) "LWPOLYLINE"))<br />               (if (= (car (nth j pldat)) 42) (/= (cdr (nth j pldat)) 0.0) (progn (setq chanyn T) (setq j (length pldat)))  ) <br />           )<br />          (cond ( (and (= (cdr (assoc 0 pldat)) "LWPOLYLINE")  chanyn)<br />                 (setq startpt (assoc 10 pldat))<br />                 (setq endpt (assoc 10 (reverse pldat)))<br />                 (setq npldat nil)<br />                 (setq j 0 totalp 0)<br />                 (while (< j (length pldat))<br />                  (if (and (= (car (nth j pldat)) 10)  (= (car (nth (+ j 3) pldat)) 42) (/= (cdr (nth (+ j 3) pldat)) 0.0) )<br />                    (progn<br />                     (setq midptl (list (nth j pldat) '(40 . 0.0) '(41 . 0.0) '(42 . 0.0)))<br />                     (setq totalp (1+ totalp))<br />                     (setq npldat (append npldat midptl))<br />                     (setq arcSP (cdr (nth j pldat)))<br />                     (setq arcEP (cdr (nth (+ j 4) pldat)))                         <br />                     (if  (and (> (abs (- (/ code70 2.0) (fix (/ code70 2.0)))) 0.49) (= (car (nth (+ j 4) pldat)) 210)) <br />                         (setq arcEP (cdr (assoc 10 pldat)))  );if<br />                     (setq arcAn (* (atan (cdr (nth (+ j 3) pldat))) 2))<br />                     (setq strin (/ (mdist arcSP arcEP) 2))<br />                     (setq arcR (/ strin (sin arcAn)))<br />                     (setq fwjSE (angle arcSP arcEP))<br />                     (setq cenPT (polar arcSP (+ fwjSE (- (/ pi 2.0) arcAn)) arcR))<br />                     (setq fwjCS (angle cenPT arcSP))<br />                     (setq fwjCE (angle cenPT arcEP))<br />                     (setq jiaJ (abs (- fwjCE fwjCS)))<br />                     (if (and (> fwjCE fwjCS) (< (cdr (nth (+ j 3) pldat)) 0)) (setq jiaj (- (* pi 2.0) jiaj)))<br />                     (if (and (< fwjCE fwjCS) (> (cdr (nth (+ j 3) pldat)) 0)) (setq jiaj (- (* pi 2.0) jiaj)))<br />                     (setq addAn  (/ sn arcR))<br />                     (setq fwjCM (+ fwjCS addAn))<br />                     (setq repnum (fix (abs (/ jiaj addAn))))                    <br />                     (if  (and (< (abs (- (/ code70 2.0) (fix (/ code70 2.0)))) 0.001) (= (car (nth (+ j 4) pldat)) 210)) <br />                          (progn <br />                             (setq repnum 0) <br />                             (setq npldat (append npldat (list (nth j pldat)))) <br />                             (setq totalp (1+ totalp))<br />                           )<br />                          (repeat repnum<br />                            (setq midpt (polar cenPT fwjCM (abs arcR)))<br />                            (setq midptl (list (cons '10 midpt) '(40 . 0.0) '(41 . 0.0) '(42 . 0.0)))<br />                            (setq totalp (1+ totalp))<br />                            (setq npldat (append npldat midptl))<br />                            (setq fwjCM (+ fwjCM addAn)));r<br />                      );if<br />                      (setq j (+ 3 j))<br />                    );pr <br />                  (progn (setq npldat (append npldat (list (nth j pldat))))<br />                  (if (= (car (nth j pldat)) 10) (setq totalp (1+ totalp))    ))<br />                  );if<br />                  (setq j (1+ j))<br />                 );wh<br />                 (setq npldat (subst  (cons 90 totalp) (assoc 90 npldat) npldat))<br />                 (entmod npldat) <br />                );cond-1<br />          ((= (cdr (assoc 0 pldat)) "POLYLINE")<br />            (if (or (= code70 2) (= code70 3) (= code70 4) (= code70 5) <br />                    (= code70 130) (= code70 131) (= code70 132) (= code70 133)) <br />                    (progn      <br />            (getplp (ssname ssp i))<br />            ;(command "pedit" (ssname ssp i) "D" "")<br />            ;(setq tmpels (entget (ssname ssp i)))<br />            ;(setq startp (assoc 10 tmpels))<br />            ;(setq endpt (assoc 10 (reverse tmpels)))<br />            (setq startp (cons 10 (car plpt)))<br />            (setq endpt (cons 10 (last plpt)))<br />            (command "layer" "s" "df-point" "")<br />            (if (> (mdist (car plpt) (last plpt)) (* sn 2.0)) (command "measure" (ssname ssp i) sn) (command "measure" (ssname ssp i) (/ (mdist (car plpt) (last plpt)) 3.0)))           <br />            (setq sspt nil)<br />            (setq sspt (ssget "x" '((8 . "df-point") (0 . "POINT"))))<br />                    (if (= (setq entlt (cdr (assoc 6 pldat))) nil) (setq entlt "bylayer") )<br />                    (if (= (setq entth (cdr (assoc 39 pldat))) nil) (setq entth 0) )<br />                    (if (= (setq entco (cdr (assoc 62 pldat))) nil) (setq entco "bylayer") )<br />                    (command "clayer" (cdr (assoc 8 pldat)) "color" entco "celtype" entlt "thickness" entth) <br />                  (entmake pldat)<br />                  (setq ii (1- (sslength sspt)))<br />                  (if (< (abs (- (/ code70 2.0) (fix (/ code70 2.0)) ))  0.01) (entmake (list '(0 . "VERTEX") startp))) <br />                  (repeat (sslength sspt) <br />                          (setq tmpels (assoc 10 (entget (ssname sspt ii)))) <br />                          (entmake (list '(0 . "VERTEX") tmpels))   <br />                          (setq ii (1- ii))    );r<br />                   (if (< (abs (- (/ code70 2.0) (fix (/ code70 2.0))))  0.01) (entmake (list '(0 . "VERTEX") endpt)))<br />                   (entmake (list '(0 . "SEQEND")))<br />                   (command "_.erase" sspt "")<br />                   (entdel  (ssname ssp i))<br />                   (command "pedit" (entlast) "d" "")<br />          ));pr;if                  <br />          );cond-2  <br />          );cond <br />       (setq i (1+ i))<br />       );r<br /> (setq ssp nil)<br /> );wh<br /> ;(command "undo" "E")<br /> (setvar "cmdecho" syscmd)<br /> (princ)<br /> )<br /> <br />