填方路基横断面自动分层？

树櫴希德

1. (defun LM:outline (sel      /       LM:ssboundingbox  app
   
2.        are      box       cmd      dis      enl
   
3.        ent      lst       obj      rtn      tmp
   
4.       )
   
5.   (defun LM:ssboundingbox (s / a b i m n o)
   
6.     (repeat (setq i (sslength s))
   
7.       (if
   
8.   (and
   
9.     (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
   
10.     (vlax-method-applicable-p o 'getboundingbox)
    
11.     (not
    
12.       (vl-catch-all-error-p
    
13.         (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))
    
14.       )
    
15.     )
    
16.   )
    
17.    (setq m (cons (vlax-safearray->list a) m)
    
18.          n (cons (vlax-safearray->list b) n)
    
19.    )
    
20.       )
    
21.     )
    
22.     (if  (and m n)
    
23.       (mapcar '(lambda (a b) (apply 'mapcar (cons a b)))
    
24.         '(min max)
    
25.         (list m n)
    
26.       )
    
27.     )
    
28.   )
    
29.   (if (setq box (LM:ssboundingbox sel))
    
30.     (progn
    
31.       (setq app  (vlax-get-acad-object)
    
32.       dis  (/ (apply 'distance box) 20.0)
    
33.       lst  (mapcar  '(lambda (a o) (mapcar o a (list dis dis)))
    
34.       box
    
35.       '(- +)
    
36.     )
    
37.       are  (apply '* (apply 'mapcar (cons '- (reverse lst))))
    
38.       dis  (* dis 1.5)
    
39.       ent
    
40.     (entmakex
    
41.       (append
    
42.         '((000 . "LWPOLYLINE")
    
43.           (100 . "AcDbEntity")
    
44.           (100 . "AcDbPolyline")
    
45.           (090 . 4)
    
46.           (070 . 1)
    
47.          )
    
48.         (mapcar '(lambda (x)
    
49.              (cons 10 (mapcar '(lambda (y) ((eval y) lst)) x))
    
50.            )
    
51.           '((caar cadar)
    
52.             (caadr cadar)
    
53.             (caadr cadadr)
    
54.             (caar cadadr)
    
55.            )
    
56.         )
    
57.       )
    
58.     )
    
59.       )
    
60.       (apply
    
61.   'vlax-invoke
    
62.   (vl-list* app
    
63.       'zoomwindow
    
64.       (mapcar '(lambda (a o) (mapcar o a (list dis dis 0.0)))
    
65.         box
    
66.         '(- +)
    
67.       )
    
68.   )
    
69.       )
    
70.       (setq cmd  (getvar 'cmdecho)
    
71.       enl  (entlast)
    
72.       rtn  (ssadd)
    
73.       )
    
74.       (while (setq tmp (entnext enl)) (setq enl tmp))
    
75.       (setvar 'cmdecho 0)
    
76.       (command
    
77.   "_.-boundary"
    
78.   "_a"
    
79.   "_b"
    
80.   "_n"
    
81.   sel
    
82.   ent
    
83.   ""
    
84.   "_i"
    
85.   "_y"
    
86.   "_o"
    
87.   "_p"
    
88.   ""
    
89.   (trans (mapcar '- (car box) (list (/ dis 3.0) (/ dis 3.0)))
    
90.          0
    
91.          1
    
92.   )
    
93.   ""
    
94.       )
    
95.       (while (< 0 (getvar 'cmdactive)) (command ""))
    
96.       (entdel ent)
    
97.       (while (setq enl (entnext enl))
    
98.   (if (and (vlax-property-available-p
    
99.        (setq obj (vlax-ename->vla-object enl))
    
100.        'area
     
101.      )
     
102.      (equal (vla-get-area obj) are 1e-4)
     
103.       )
     
104.     (entdel enl)
     
105.     (ssadd enl rtn)
     
106.   )
     
107.       )
     
108.       (vla-zoomprevious app)
     
109.       (setvar 'cmdecho cmd)
     
110.       rtn
     
111.     )
     
112.   )
     
113. )
     
114. 
     
115. ;(LM:outline(ssget))
     
116. 
     
117. (defun PoInPl(pt lst / i p1 p2 an anl ret)
     
118.     (setq i -1 p1 (last lst))
     
119.     (while(and(not ret)(setq p2(nth(setq i(1+ i))lst)))
     
120.       (cond((equal p2 pt 1e-6)(setq ret t))
     
121.      (t(setq an(-(angle pt p1)(angle pt p2)))
     
122.       (if(equal pi(abs an) 1e-6)
     
123.         (setq ret t)
     
124.         (setq anl(cons(rem an PI)anl)))))
     
125.       (setq p1 p2))
     
126.     (cond(ret 0);线上;
     
127.    (t(if(equal PI(abs(apply'+ anl))1e-6)1 -1))))
     
128. 
     
129. 
     
130. (defun vxs(e / p a b n ob q et d d1 en et)
     
131.     (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
     
132.     (cond((="LWPOLYLINE"et)
     
133.     (repeat(length a)(setq b (nth n a) n (+ n 1))
     
134.       (if (= 10 (car b))(progn
     
135.         (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
     
136.         (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
     
137.           (setq p (list q)))))))
     
138.    ((="OLYLINE"et)
     
139.     (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
     
140.     (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
     
141.       (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
     
142.       (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
     
143.       (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
     
144.     (setq p(reverse p))))P)
     
145. ;;;;;;;;;;
     
146. (vl-load-com)
     
147. (defun c:dmfc (  / zxbl pt p1 p2 p3 p4  fchd lst gcz nn i ss  p5);
     
148. (setq fchd (getreal "\n请输入回填土压实后厚度(一般0.25米) :"))
     
149. (setq zxbl (getint "\n请输入断面纵向比例 1 :"))
     
150.   (setq pt (getpoint "\n请点击横断面图上96区顶中桩位置 :"))
     
151. (setq p1 (car(entsel "\n请选择96区顶横断面多段线：")))
     
152.   (setq p2 (car(entsel "\n请选择左边坡断面多段线：")))
     
153.   (setq p3 (car(entsel "\n请选择右边坡横断面多段线：")))
     
154.   (setq p4 (car(entsel "\n请选择原地面横断面多段线：")))
     
155.   (setq ss(ssadd)) (ssadd p1 ss)(ssadd p2 ss)(ssadd p3 ss)(ssadd p4 ss)
     
156.   (LM:outline ss ) (setq p5 (entlast))
     
157. 
     
158. (setq lst (vl-sort (vxs p4)(function (lambda (e1 e2) (< (cadr e1) (cadr e2))))))
     
159. 
     
160. (setq gcz (* (- (cadr pt)  (cadr(car lst))  ) (/ zxbl 1000.000)  )  )
     
161. 
     
162. (setq nn (fix (/ gcz fchd)))
     
163. (setq i 0)
     
164. (repeat  (- nn 1)
     
165.   (setvar "osmode" 16384) (setvar "CMDECHO" 0)
     
166. (command "_.copy" p1 "" pt (polar pt (* 1.5 pi ) (/ (* fchd (+ i 1)) (/ zxbl 1000.000)  )   )   "" )
     
167.   ;
     
168.   (command "_.extend"  p2   "" (list  (entlast)(car(vxs (entlast)))) "" )
     
169.   (command "_.extend"  p2   "" (list (entlast) (last(vxs (entlast))) ) "" )
     
170. 
     
171.   (command "_.extend"  p3   "" (list  (entlast)(car(vxs (entlast)))) "" )
     
172.   (command "_.extend"  p3   "" (list (entlast) (last(vxs (entlast))) ) "" )
     
173. (command "_.extend"  p4   "" (list  (entlast)(car(vxs (entlast)))) "" )
     
174.   (command "_.extend"  p4   "" (list (entlast) (last(vxs (entlast))) ) "" )
     
175.   
     
176.   (cond   (  (>=  (poinpl (car(vxs (entlast))) (vxs p5))  0 )                ;
     
177. 
     
178.        (command "_.trim"  p4 "" (list (entlast) (last(vxs (entlast))) )  "" )  )
     
179. 
     
180. (  (>=  (poinpl (last (vxs (entlast))) (vxs p5))  0 )                ;
     
181. 
     
182.        (command "_.trim"  p4 "" (list (entlast) (car(vxs (entlast))) )  "" )  )
     
183. 
     
184.     )
     
185.   
     
186. (setq i (1+ i))
     
187. 
     
188. 
     
189.   )
     
190. (entdel p5)
     
191. 
     
192. 
     
193. (setvar "osmode" 9) (setvar "CMDECHO" 1)
     
194. (princ)
     
195.   )

(defun LM:outline (sel      /       LM:ssboundingbox  app<br />        are      box       cmd      dis      enl<br />        ent      lst       obj      rtn      tmp<br />       )<br />   (defun LM:ssboundingbox (s / a b i m n o)<br />     (repeat (setq i (sslength s))<br />       (if<br />   (and<br />     (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))<br />     (vlax-method-applicable-p o 'getboundingbox)<br />     (not<br />       (vl-catch-all-error-p<br />         (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))<br />       )<br />     )<br />   )<br />    (setq m (cons (vlax-safearray->list a) m)<br />          n (cons (vlax-safearray->list b) n)<br />    )<br />       )<br />     )<br />     (if  (and m n)<br />       (mapcar '(lambda (a b) (apply 'mapcar (cons a b)))<br />         '(min max)<br />         (list m n)<br />       )<br />     )<br />   )<br />   (if (setq box (LM:ssboundingbox sel))<br />     (progn<br />       (setq app  (vlax-get-acad-object)<br />       dis  (/ (apply 'distance box) 20.0)<br />       lst  (mapcar  '(lambda (a o) (mapcar o a (list dis dis)))<br />       box<br />       '(- +)<br />     )<br />       are  (apply '* (apply 'mapcar (cons '- (reverse lst))))<br />       dis  (* dis 1.5)<br />       ent<br />     (entmakex<br />       (append<br />         '((000 . "LWPOLYLINE")<br />           (100 . "AcDbEntity")<br />           (100 . "AcDbPolyline")<br />           (090 . 4)<br />           (070 . 1)<br />          )<br />         (mapcar '(lambda (x)<br />              (cons 10 (mapcar '(lambda (y) ((eval y) lst)) x))<br />            )<br />           '((caar cadar)<br />             (caadr cadar)<br />             (caadr cadadr)<br />             (caar cadadr)<br />            )<br />         )<br />       )<br />     )<br />       )<br />       (apply<br />   'vlax-invoke<br />   (vl-list* app<br />       'zoomwindow<br />       (mapcar '(lambda (a o) (mapcar o a (list dis dis 0.0)))<br />         box<br />         '(- +)<br />       )<br />   )<br />       )<br />       (setq cmd  (getvar 'cmdecho)<br />       enl  (entlast)<br />       rtn  (ssadd)<br />       )<br />       (while (setq tmp (entnext enl)) (setq enl tmp))<br />       (setvar 'cmdecho 0)<br />       (command<br />   "_.-boundary"<br />   "_a"<br />   "_b"<br />   "_n"<br />   sel<br />   ent<br />   ""<br />   "_i"<br />   "_y"<br />   "_o"<br />   "_p"<br />   ""<br />   (trans (mapcar '- (car box) (list (/ dis 3.0) (/ dis 3.0)))<br />          0<br />          1<br />   )<br />   ""<br />       )<br />       (while (< 0 (getvar 'cmdactive)) (command ""))<br />       (entdel ent)<br />       (while (setq enl (entnext enl))<br />   (if (and (vlax-property-available-p<br />        (setq obj (vlax-ename->vla-object enl))<br />        'area<br />      )<br />      (equal (vla-get-area obj) are 1e-4)<br />       )<br />     (entdel enl)<br />     (ssadd enl rtn)<br />   )<br />       )<br />       (vla-zoomprevious app)<br />       (setvar 'cmdecho cmd)<br />       rtn<br />     )<br />   )<br /> )<br /> <br /> ;(LM:outline(ssget))<br /> <br /> (defun PoInPl(pt lst / i p1 p2 an anl ret)<br />     (setq i -1 p1 (last lst))<br />     (while(and(not ret)(setq p2(nth(setq i(1+ i))lst)))<br />       (cond((equal p2 pt 1e-6)(setq ret t))<br />      (t(setq an(-(angle pt p1)(angle pt p2)))<br />       (if(equal pi(abs an) 1e-6)<br />         (setq ret t)<br />         (setq anl(cons(rem an PI)anl)))))<br />       (setq p1 p2))<br />     (cond(ret 0);线上;<br />    (t(if(equal PI(abs(apply'+ anl))1e-6)1 -1))))<br /> <br /> <br /> (defun vxs(e / p a b n ob q et d d1 en et)<br />     (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)<br />     (cond((="LWPOLYLINE"et)<br />     (repeat(length a)(setq b (nth n a) n (+ n 1))<br />       (if (= 10 (car b))(progn<br />         (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))<br />         (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))<br />           (setq p (list q)))))))<br />    ((="<img src="static/image/smiley/default/titter.gif" smilieid="9" border="0" alt="" />OLYLINE"et)<br />     (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))<br />     (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")<br />       (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))<br />       (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))<br />       (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))<br />     (setq p(reverse p))))P)<br /> ;;;;;;;;;;<br /> (vl-load-com)<br /> (defun c:dmfc (  / zxbl pt p1 p2 p3 p4  fchd lst gcz nn i ss  p5);<br /> (setq fchd (getreal "\n请输入回填土压实后厚度(一般0.25米) :"))<br /> (setq zxbl (getint "\n请输入断面纵向比例 1 :"))<br />   (setq pt (getpoint "\n请点击横断面图上96区顶中桩位置 :"))<br /> (setq p1 (car(entsel "\n请选择96区顶横断面多段线：")))<br />   (setq p2 (car(entsel "\n请选择左边坡断面多段线：")))<br />   (setq p3 (car(entsel "\n请选择右边坡横断面多段线：")))<br />   (setq p4 (car(entsel "\n请选择原地面横断面多段线：")))<br />   (setq ss(ssadd)) (ssadd p1 ss)(ssadd p2 ss)(ssadd p3 ss)(ssadd p4 ss)<br />   (LM:outline ss ) (setq p5 (entlast))<br /> <br /> (setq lst (vl-sort (vxs p4)(function (lambda (e1 e2) (< (cadr e1) (cadr e2)))))) <br /> <br /> (setq gcz (* (- (cadr pt)  (cadr(car lst))  ) (/ zxbl 1000.000)  )  )<br /> <br /> (setq nn (fix (/ gcz fchd)))<br /> (setq i 0)<br /> (repeat  (- nn 1)<br />   (setvar "osmode" 16384) (setvar "CMDECHO" 0)<br /> (command "_.copy" p1 "" pt (polar pt (* 1.5 pi ) (/ (* fchd (+ i 1)) (/ zxbl 1000.000)  )   )   "" )<br />   ;<br />   (command "_.extend"  p2   "" (list  (entlast)(car(vxs (entlast)))) "" )<br />   (command "_.extend"  p2   "" (list (entlast) (last(vxs (entlast))) ) "" )<br /> <br />   (command "_.extend"  p3   "" (list  (entlast)(car(vxs (entlast)))) "" )<br />   (command "_.extend"  p3   "" (list (entlast) (last(vxs (entlast))) ) "" )<br /> (command "_.extend"  p4   "" (list  (entlast)(car(vxs (entlast)))) "" )<br />   (command "_.extend"  p4   "" (list (entlast) (last(vxs (entlast))) ) "" )<br />   <br />   (cond   (  (>=  (poinpl (car(vxs (entlast))) (vxs p5))  0 )                ;<br /> <br />        (command "_.trim"  p4 "" (list (entlast) (last(vxs (entlast))) )  "" )  )<br /> <br /> (  (>=  (poinpl (last (vxs (entlast))) (vxs p5))  0 )                ;<br /> <br />        (command "_.trim"  p4 "" (list (entlast) (car(vxs (entlast))) )  "" )  )<br /> <br />     )<br />   <br /> (setq i (1+ i)) <br /> <br /> <br />   )<br /> (entdel p5)<br /> <br /> <br /> (setvar "osmode" 9) (setvar "CMDECHO" 1)<br /> (princ)<br />   )

树櫴希德

李苹果大神 的直线多段线包围盒 DDXBWH

树櫴希德

旧版有问题

1. ;;
   
2. ;;;
   
3. ;;;    EXTRIM.LSP
   
4. ;;;    Copyright ?1999 by Autodesk, Inc.
   
5. ;;;
   
6. ;;;    Your use of this software is governed by the terms and conditions of the
   
7. ;;;    License Agreement you accepted prior to installation of this software.
   
8. ;;;    Please note that pursuant to the License Agreement for this software,
   
9. ;;;    "[c]opying of this computer program or its documentation except as
   
10. ;;;    permitted by this License is copyright infringement under the laws of
    
11. ;;;    your country.  If you copy this computer program without permission of
    
12. ;;;    Autodesk, you are violating the law."
    
13. ;;;
    
14. ;;;    AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
    
15. ;;;    AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
    
16. ;;;    MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK, INC.
    
17. ;;;    DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
    
18. ;;;    UNINTERRUPTED OR ERROR FREE.
    
19. ;;;
    
20. ;;;    Use, duplication, or disclosure by the U.S. Government is subject to
    
21. ;;;    restrictions set forth in FAR 52.227-19 (Commercial Computer
    
22. ;;;    Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
    
23. ;;;    (Rights in Technical Data and Computer Software), as applicable.
    
24. ;;;
    
25. ;;;  ----------------------------------------------------------------
    
26. 
    
27. 
    
28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
29. ;Extended-TRIM - cookie-cutter routine
    
30. ;
    
31. ;Select a polyline, line, circle or arc and a side to trim on
    
32. ;
    
33. (defun pzx-extrim (na p1 / na e1 p1 redraw_it lst n )
    
34. 
    
35. (acet-error-init (list
    
36.                    (list   "cmdecho" 0
    
37.                          "highlight" 0
    
38.                          "regenmode" 1
    
39.                             "osmode" 0
    
40.                            "ucsicon" 0
    
41.                         "offsetdist" 0
    
42.                             "attreq" 0
    
43.                           "plinewid" 0
    
44.                          "plinetype" 1
    
45.                           "gridmode" 0
    
46.                            "celtype" "CONTINUOUS"
    
47.                          "ucsfollow" 0
    
48.                           "limcheck" 0
    
49.                    )
    
50.                    T     ;flag. True means use undo for error clean up.
    
51.                    '(if redraw_it (redraw na 4))
    
52.                   );list
    
53. );acet-error-init
    
54. 
    
55. 
    
56. (princ "\nPick a POLYLINE, LINE, CIRCLE, ARC, ELLIPSE, IMAGE or TEXT for cutting edge...")
    
57. ;setq
    
58. (if na
    
59.     (progn
    
60.      (setq e1 (entget na));;setq
    
61.      (if (or (equal "TEXT"   (cdr (assoc 0 e1)))
    
62.              (equal "MTEXT"  (cdr (assoc 0 e1)))
    
63.              (equal "ATTDEF" (cdr (assoc 0 e1)))
    
64.              (equal "IMAGE"  (cdr (assoc 0 e1)))
    
65.              (equal "INSERT" (cdr (assoc 0 e1)))
    
66.              (equal "SOLID"  (cdr (assoc 0 e1)))
    
67.              (equal "3DFACE" (cdr (assoc 0 e1)))
    
68.              (equal "TRACE"  (cdr (assoc 0 e1)))
    
69.          );or
    
70.          (progn
    
71.           (setq lst (acet-geom-object-point-list na nil))
    
72.           (setq n 0)
    
73.           (command "_.pline")
    
74.           (repeat (length lst)
    
75.           (command (nth n lst))
    
76.           (setq n (+ n 1));setq
    
77.           );repeat
    
78.           (if (not (equal (car lst) (last lst) 0.0000001))
    
79.               (command "_cl")
    
80.               (command "")
    
81.           );if
    
82.           (setq na (entlast)
    
83.                 e1 na
    
84.           );setq
    
85.          );progn then draw a temp pline to be the cutting edge.
    
86.          (setq e1 nil)
    
87.      );if
    
88.      (redraw na 3)
    
89.      (setq redraw_it T)
    
90. 
    
91.      ;setq
    
92.      (redraw na 4)
    
93.      (setq redraw_it nil)
    
94.      (if p1 (etrim na p1));if
    
95.      (if e1
    
96.          (progn
    
97.           (if (setq p1 (acet-layer-locked (getvar "clayer")))
    
98.               (command "_.layer" "_un" (getvar "clayer") "")
    
99.           );if
    
100.           (entdel e1)
     
101.           (if p1
     
102.               (command "_.layer" "_lock" (getvar "clayer") "")
     
103.           );if
     
104.          );progn then
     
105.      );if
     
106.     );progn
     
107. );if
     
108. 
     
109. (acet-error-restore)
     
110. (princ)
     
111. );defun c:extrim
     
112. 
     
113. ;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     
114. ;Entity-TRIM function
     
115. ;takes: na - entity name
     
116. ;  a - a point, the side to trim on
     
117. ;NOTE: This function does not allow for the possible miss of
     
118. ;      non-continuous linetypes.
     
119. ;
     
120. (defun etrim ( na a / la b d e1 lst lst2 n j k m ss na2 na3 na4
     
121.                       x y z flag flag2 flag3 zlst vpna vplocked
     
122.              )
     
123. 
     
124. 
     
125. (setq e1 (entget na));setq
     
126. (if (or (setq flag (equal (acet-dxf 0 e1) "OLYLINE"))
     
127.         (setq flag (equal (acet-dxf 0 e1) "LWPOLYLINE"))
     
128.         (equal (acet-dxf 0 e1) "LINE")
     
129.         (equal (acet-dxf 0 e1) "CIRCLE")
     
130.         (equal (acet-dxf 0 e1) "ARC")
     
131.         (equal (acet-dxf 0 e1) "ELLIPSE")
     
132.         (equal (acet-dxf 0 e1) "TEXT")
     
133.         (equal (acet-dxf 0 e1) "ATTDEF")
     
134.         (equal (acet-dxf 0 e1) "MTEXT")
     
135.         (equal (acet-dxf 0 e1) "SPLINE")
     
136.     );or
     
137.     (progn
     
138.      (if (and flag
     
139.               (equal 8 (logand 8 (acet-dxf 70 e1)))
     
140.          );and
     
141.          (setq flag nil)
     
142.      );if
     
143.      (setq     a (trans a 1 0)
     
144.             vpna (acet-currentviewport-ename)
     
145.      );setq
     
146.      (acet-ucs-cmd (list "_View"))
     
147. 
     
148.      (setq   lst (acet-geom-object-point-list na nil)  ;;;find extents of selected cutting edge object
     
149.              lst (acet-geom-list-extents lst)
     
150.                x (- (car (cadr lst)) (car (car lst)))
     
151.                y (- (cadr (cadr lst)) (cadr (car lst)))
     
152.                x (* 0.075 x)
     
153.                y (* 0.075 y)
     
154.                z (list x y)
     
155.                x (list (+ (car (cadr lst)) (car z))
     
156.                        (+ (cadr (cadr lst)) (cadr z))
     
157.                  );list
     
158.                y (list (- (car (car lst)) (car z))
     
159.                        (- (cadr (car lst)) (cadr z))
     
160.                  );list
     
161.             zlst (zoom_2_object (list x y))
     
162.      );setq
     
163.      (if vpna
     
164.          (setq vplocked (acet-viewport-lock-set vpna nil)) ;unlock cur viewport if needed.
     
165.      );if
     
166.      (command "_.zoom" "_w" (car zlst) (cadr zlst))
     
167. 
     
168.      (entupd na)                  ;;;update the ent. so it's curves display smoothly
     
169. 
     
170.      (setq lst (acet-geom-object-point-list na
     
171.                        (/ (acet-geom-pixel-unit) 2.0)
     
172.                )
     
173.      );setq
     
174.      (if (or (not flag)
     
175.              (not (acet-geom-self-intersect lst nil))
     
176.          );or
     
177.          (progn             ;then the object is valid and not a self intersecting polyline.
     
178.           (if (and flag
     
179.                    (equal (car lst) (last lst) 0.0001)
     
180.               );and
     
181.               (setq flag3 T);then the polyline could potentialy need a second offset
     
182.           );if
     
183.           (if (setq la (acet-layer-locked (getvar "clayer")))
     
184.               (command "_.layer" "_unl" (getvar "clayer") "")
     
185.           );if
     
186. 
     
187.           (command "_.pline")
     
188.           (setq b nil)
     
189.           (setq n 0);setq
     
190.           (repeat (length lst)
     
191.            (setq d (nth n lst))
     
192.            (if (not (equal d b 0.0001))
     
193.               (progn
     
194.                (command d)
     
195.                (setq lst2 (append lst2 (list d)));setq
     
196.                (setq b d);setq
     
197.               );progn
     
198.            );if
     
199.            (setq n (+ n 1))
     
200.           );repeat
     
201.           (command "")
     
202.           (setq  na2 (entlast)
     
203.                   ss (ssadd)
     
204.                   ss (ssadd na2 ss)
     
205.                  lst nil
     
206.           );setq
     
207.           (acet-ss-visible ss 1)
     
208.           (setq lst2 (get_fence_points na2 a lst2 flag3 flag));setq
     
209. 
     
210.           (if la
     
211.               (command "_.layer" "_lock" (getvar "clayer") "")
     
212.           );if
     
213.           (acet-ucs-cmd (list "_p"))
     
214.           ;Move the ents to force a display update of the ents to avoid viewres problems.
     
215.           (setvar "highlight" 0)
     
216.           (if (setq ss (ssget "_f" (last lst2)))
     
217.               (command "_.move" ss "" "0,0,0" "0,0,0")
     
218.           );if
     
219.           (if flag
     
220.               (progn
     
221.                (if (setq la (acet-layer-locked (acet-dxf 8 e1)))
     
222.                    (command "_.layer" "_unl" (acet-dxf 8 e1) "")
     
223.                );if
     
224.                (acet-ucs-set-z (acet-dxf 210 e1))
     
225.                (command "_.copy" na "" "0,0,0" "0,0,0")
     
226.                ;(entdel na)
     
227.                (acet-ss-visible (ssadd na (ssadd)) 1);make it invisible for a while.
     
228.                                                     ;rk 12:01 PM 3/10/98
     
229.                (setq na3 na
     
230.                       na (entlast)
     
231.                );setq
     
232.                (command "_.pedit" na "_w" "0.0" "_x")
     
233.                (acet-ucs-cmd (list "_p"))
     
234.                (if la (command "_.layer" "_lock" (acet-dxf 8 e1) ""));if
     
235.               );progn
     
236.           );if
     
237.           (command "_.trim" na "")
     
238.           (setq m (- (length lst2) 1));setq
     
239.           (setq k 0)
     
240.           (repeat (length lst2)
     
241.            (setq lst (nth k lst2))
     
242.            (setq a (trans (car lst) 0 1))
     
243.            (setq n 1)
     
244.            (repeat (- (length lst) 1) ;repeat each fence list
     
245.             (setq b (trans (nth n lst) 0 1))
     
246.             (if (equal a b 0.0001)
     
247.                 (setq flag2 T)
     
248.                 (setq flag2 nil)
     
249.             );if
     
250.             (setq na4 nil);setq
     
251.             (setq j 0);setq
     
252.             (while (not flag2)       ;repeat each segment of the fence until no new ents are created.
     
253.              (setq na4 (entlast));setq
     
254.              (command "_F" a b "")
     
255.              (if (and (equal na4 (entlast))
     
256.                       (or (not (equal k m))
     
257.                           (> j 0)
     
258.                       );or
     
259.                  );and
     
260.                  (setq flag2 T)
     
261.              );if
     
262.              (setq j (+ j 1));setq
     
263.             );while
     
264.             (setq a b);setq
     
265.             (setq n (+ n 1));setq
     
266.            );repeat
     
267. 
     
268.            (setq k (+ k 1))
     
269.           );repeat
     
270.           (command "")
     
271. 
     
272.           (if flag
     
273.               (progn
     
274.                (if (setq la (acet-layer-locked (acet-dxf 8 e1)))
     
275.                    (command "_.layer" "_unl" (acet-dxf 8 e1) "")
     
276.                );if
     
277.                (entdel na) ;get rid of the copy
     
278. 
     
279.                ;(entdel na3);bring back the original
     
280.                (acet-ss-visible (ssadd na3 (ssadd)) 0) ;bring back the original
     
281.                                                       ;rk 12:01 PM 3/10/98
     
282.                (if la (command "_.layer" "_lock" (acet-dxf 8 e1) ""));if
     
283.               );progn
     
284.           );if
     
285.          );progn
     
286.          (progn
     
287.           (acet-ucs-cmd (list "_p"))
     
288.           (princ "\nSelf intersecting edges are not acceptable.")
     
289.          );progn else invalid self intersecting polyline
     
290.      );if
     
291.      (command "_.zoom" "_p")
     
292.      (if vplocked
     
293.          (acet-viewport-lock-set vpna T) ;then re-lock the viewport
     
294.      );if
     
295.     );progn then it's a most likely a valid entity.
     
296. );if
     
297. );defun etrim
     
298. 
     
299. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
300. (defun another_offset ( pl1 pl2 a1 a2 b na2 lst2 a lst3 lst4 / na ss lst da1 da2)
     
301. 
     
302. (setq da1 (abs (- a2 a1)));setq
     
303. (setq da2 (- (* b (max pl2 pl1))
     
304.              (/ (* b (abs (- pl2 pl1)))
     
305.                  2.0
     
306.              )
     
307.           )
     
308. );setq
     
309. (if (> (abs (- da2 da1))
     
310.        (* 0.01 (max a1 a2))
     
311.     )
     
312.     (progn
     
313. 
     
314.      (acet-pline-make (list lst2))
     
315.      (setq  na (entlast)
     
316.            na2 (entlast)
     
317.             ss (ssadd)
     
318.             ss (ssadd na ss)
     
319.      );setq
     
320.      (acet-ss-visible ss 1)
     
321.      (command "_.offset" b na2 a "")
     
322.      (if (and (not (equal na (entlast)))
     
323.               (setq lst3 (acet-geom-vertex-list (entlast)))
     
324.               (setq lst3 (intersect_check lst2 lst3 lst4))
     
325.          );and
     
326.          (progn
     
327.           (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
     
328.           (command "_.area" "_ob" (entlast))
     
329.           (setq pl2 (getvar "perimeter")
     
330.                  a2 (getvar "area")
     
331.           );setq
     
332.           (setq lst (list (acet-geom-vertex-list (list (entlast) 0))));setq
     
333.           (entdel (entlast));then offset was a success so delete the ent after getting it's info
     
334.          );progn then
     
335.          (if (not (equal na (entlast))) (entdel (entlast)));if else
     
336.      );if
     
337.      (entdel na2)
     
338.     );progn then let's do that second offset
     
339. );if
     
340. 
     
341. lst
     
342. );defun another_offset
     
343. 
     
344. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
345. (defun get_fence_points ( na2 a lst2 flag plflag / a1 a2 pl1 pl2 b c d n
     
346.                                                    lst lst2 lst3 lst4 na
     
347.                         )
     
348. 
     
349. (if flag
     
350.     (progn
     
351.      (setq lst2 (cdr lst2));setq
     
352.      (repeat (fix (/ (length lst2) 2))
     
353.       (setq lst2 (append (cdr lst2) (list (car lst2)));append
     
354.       );setq
     
355.      );repeat
     
356.      (setq lst2 (append lst2 (list (car lst2))));setq
     
357.      (command "_.area" "_ob" na2)
     
358.      (setq pl1 (getvar "perimeter")
     
359.             a1 (getvar "area")
     
360.      );setq
     
361.     );progn
     
362. );if
     
363. 
     
364. (setq    a (trans a 0 1)
     
365.          b (* (getvar "viewsize") 0.05);initial offset distance
     
366.          n 3.0                         ;number of offsets
     
367.          d (/ b (- n 1))               ;delta offset
     
368.          c (acet-geom-pixel-unit)
     
369.       lst4 (acet-geom-view-points)
     
370. );setq
     
371. 
     
372. (while (> b c)
     
373. (setq na (entlast))
     
374. (command "_.offset" b na2 a "")
     
375. (if (and (not (equal na (entlast)))
     
376.          (setq lst3 (acet-geom-vertex-list (entlast)))
     
377.          (or (not plflag)
     
378.              (setq lst3 (intersect_check lst2 lst3 lst4))
     
379.          );or
     
380.     );and
     
381.     (progn
     
382.      (setq lst3 (acet-geom-m-trans lst3 1 0))
     
383.      (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
     
384.      (if flag
     
385.          (progn
     
386.           (command "_.area" "_ob" (entlast))
     
387.           (setq pl2 (getvar "perimeter")
     
388.                  a2 (getvar "area")
     
389.           );setq
     
390.          );progn
     
391.      );if
     
392.      (setq lst (append lst (list lst3)));setq
     
393.      (entdel (entlast))  ;delete the ent after getting it's vertex info
     
394.      (if flag
     
395.          (setq lst (append lst
     
396.                            (another_offset pl1 pl2 a1 a2 b na2 lst2 a lst3 lst4)
     
397.                    );append
     
398.          );setq
     
399.      );if
     
400.     );progn then offset was a success
     
401.     (if (not (equal na (entlast))) (entdel (entlast)));if else
     
402. );if
     
403. (setq b (- b d));setq
     
404. );while
     
405. (setq na (entlast))
     
406. (command "_.offset" c na2 a "")
     
407. (if (and (not (equal na (entlast)))
     
408.          (setq lst3 (acet-geom-vertex-list (entlast)))
     
409.          (or (not plflag)
     
410.              (setq lst3 (intersect_check lst2 lst3 lst4))
     
411.          );or
     
412.     );and
     
413.     (progn
     
414.      (setq lst3 (acet-geom-m-trans lst3 1 0))
     
415.      (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
     
416.      (if flag
     
417.          (progn
     
418.           (command "_.area" "_ob" (entlast))
     
419.           (setq pl2 (getvar "perimeter")
     
420.                  a2 (getvar "area")
     
421.           );setq
     
422.          );progn
     
423.      );if
     
424.      (setq lst (append lst (list lst3)));setq
     
425.      (entdel (entlast));then offset was a success so delete the ent after getting it's info
     
426.      (if flag
     
427.          (setq lst (append lst
     
428.                            (another_offset pl1 pl2 a1 a2 c na2 lst2 a lst3 lst4)
     
429.                    );append
     
430.          );setq
     
431.      );if
     
432.     );progn then
     
433.     (if (not (equal na (entlast))) (entdel (entlast)));if else
     
434. );if
     
435. (entdel na2)
     
436. 
     
437. lst
     
438. );defun get_fence_points
     
439. 
     
440. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
441. ;returns a list of points on screen if the first two lists do not
     
442. ;contain segments that intersect each other.
     
443. ;
     
444. (defun intersect_check ( lst lst2 lst3 / x x2 y y2 lst4 flag len len2
     
445.                                          a aa b bb c d n j)
     
446. 
     
447. (setq  len (length lst)
     
448.       len2 (length lst2)
     
449.          x (car (car lst3))
     
450.         x2 (car (cadr lst3))
     
451.          y (cadr (car lst3))
     
452.         y2 (cadr (cadr lst3))
     
453. );setq
     
454. 
     
455. (setq n 0);setq
     
456. (while (and (not flag)
     
457.             (< (+ n 1) len2)
     
458.        );and
     
459. (setq   aa (nth n lst2)
     
460.         bb (nth (+ n 1) lst2)
     
461.          a (bns_truncate_2_view aa bb x y x2 y2)
     
462.          b (bns_truncate_2_view bb aa x y x2 y2)
     
463.       lst4 (append lst4 (list a))
     
464. );setq
     
465. (if (or (not (equal a aa))
     
466.         (not (equal b bb))
     
467.     );or
     
468.     (setq lst4 (append lst4 (list b)))
     
469. );if
     
470. (setq j 0);setq
     
471. (while (and (not flag)
     
472.              (< (+ j 1) len)
     
473.         );and
     
474. (setq    c (nth j lst)
     
475.           d (nth (+ j 1) lst)
     
476.        flag (inters a b c d)
     
477. );setq
     
478. 
     
479. (setq j (+ j 1));setq
     
480. );while
     
481. 
     
482. (setq n (+ n 1));setq
     
483. );while
     
484. (if (not (equal b (last lst4)))
     
485.     (setq lst4 (append lst4 (list b)));setq
     
486. );if
     
487. (if (not flag)
     
488.     (setq flag lst4)
     
489.     (setq flag nil)
     
490. );if
     
491. flag
     
492. );defun intersect_check
     
493. 
     
494. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
495. (defun zoom_2_object ( lst / p1 p2 p3 p4 p5 p6 mp dx dy dx2 dy2
     
496.                              r1 r2 na e1 x w h dv1 dv2 x
     
497.                      )
     
498. 
     
499. (setq  lst (acet-geom-m-trans lst 1 2)
     
500.          p1 (acet-geom-m-trans (acet-geom-view-points) 1 2)    ;p1 and p2 are the viewpnts
     
501.          p2 (cadr p1)
     
502.          p1 (car p1)
     
503.          p1 (list (car p1) (cadr p1))
     
504.          p2 (list (car p2) (cadr p2))
     
505. );setq
     
506. (if lst
     
507.      (progn
     
508.       (setq   p5 (acet-geom-list-extents lst)              ;p5 and p6 are the geometry points
     
509.               p6 (cadr p5)
     
510.               p5 (car p5)
     
511.               p5 (list (car p5) (cadr p5))
     
512.               p6 (list (car p6) (cadr p6))
     
513.               mp (acet-geom-midpoint p5 p6)           ;prepare to resize the geometry rectang to
     
514.               dx (- (car p2) (car p1))    ;have the same dy/dx ratio as p1 p2.
     
515.               dy (- (cadr p2) (cadr p1))
     
516.              dx2 (- (car p6) (car p5))
     
517.              dy2 (- (cadr p6) (cadr p5))
     
518.       );setq
     
519.       (if (equal dx 0.0)  (setq dx 0.000001))  ;just in case div by zero
     
520.       (if (equal dx2 0.0) (setq dx2 0.000001))
     
521.       (setq   r1 (/ dy dx)
     
522.               r2 (/ dy2 dx2)
     
523.       );setq
     
524.       (if (< r2 r1)
     
525.           (setq dy2 (* r1 dx2));then scale dy2 up
     
526.           (progn
     
527.            (if (equal r1 0.0)  (setq r1 0.000001))  ;just in case div by zero
     
528.            (setq dx2 (* dy2 (/ 1.0 r1)));else scale dx2 up
     
529.           );progn
     
530.       );if
     
531.       (setq p5 (list (- (car mp) (/ dx2 1.98))   ;1.98 is used instead of 2.0 to expand
     
532.                      (- (cadr mp) (/ dy2 1.98))  ;the rectangle slightly
     
533.                );list
     
534.             p6 (list (+ (car mp) (/ dx2 1.98))
     
535.                      (+ (cadr mp) (/ dy2 1.98))
     
536.                );list
     
537.       );setq
     
538.      );progn then lst
     
539. );if
     
540. (if (and lst
     
541.           (equal 0 (getvar "tilemode"))
     
542.           (not (equal 1 (getvar "cvport")))
     
543.           (setq na (acet-currentviewport-ename))
     
544.      );and
     
545.      (progn
     
546.       (setq  e1 (entget na)
     
547.               x (cdr (assoc 10 e1))
     
548.               w (cdr (assoc 40 e1))
     
549.               h (cdr (assoc 41 e1))
     
550.              p3 (list (- (car x) (/ w 2.0))
     
551.                       (- (cadr x) (/ h 2.0))
     
552.                 );list
     
553.              p4 (list (+ (car x) (/ w 2.0))
     
554.                       (+ (cadr x) (/ h 2.0))
     
555.                 );list
     
556.              p3 (trans p3 3 2)      ;p3 and p4 are the viewport points
     
557.              p4 (trans p4 3 2)
     
558.             dv1 (acet-geom-delta-vector p1 p3)
     
559.             dv2 (acet-geom-delta-vector p2 p4)
     
560.               x (distance p1 p2)
     
561.       );setq
     
562.       (if (equal 0 x) (setq x 0.000001));just in case
     
563.       (setq   x (/ (distance p5 p6)
     
564.                    x
     
565.                 )
     
566.             dv1 (acet-geom-vector-scale dv1 x)
     
567.             dv2 (acet-geom-vector-scale dv2 x)
     
568.              p5 (acet-geom-vector-add p5 dv1)
     
569.              p6 (acet-geom-vector-add p6 dv2)
     
570.        );setq
     
571.      );progn then
     
572. );if
     
573. (setq p1 (list (car p1) (cadr p1) 0.0)
     
574.        p2 (list (car p2) (cadr p2) 0.0)
     
575.        p5 (list (car p5) (cadr p5) 0.0)
     
576.        p6 (list (car p6) (cadr p6) 0.0)
     
577. );setq
     
578. (if lst
     
579.      (setq lst (list (trans p5 2 1)
     
580.                      (trans p6 2 1)
     
581.                );list
     
582.      );setq
     
583.      (setq lst nil)
     
584. );if
     
585. 
     
586. lst
     
587. );defun zoom_2_object
     
588. 
     
589. 
     
590. (princ)
     
591. 
     
592. ;;;;;;;;;;;;;;;;
     
593. (defun LM:outline (sel      /       LM:ssboundingbox  app
     
594.        are      box       cmd      dis      enl
     
595.        ent      lst       obj      rtn      tmp
     
596.       )
     
597.   (defun LM:ssboundingbox (s / a b i m n o)
     
598.     (repeat (setq i (sslength s))
     
599.       (if
     
600.   (and
     
601.     (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
     
602.     (vlax-method-applicable-p o 'getboundingbox)
     
603.     (not
     
604.       (vl-catch-all-error-p
     
605.         (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))
     
606.       )
     
607.     )
     
608.   )
     
609.    (setq m (cons (vlax-safearray->list a) m)
     
610.          n (cons (vlax-safearray->list b) n)
     
611.    )
     
612.       )
     
613.     )
     
614.     (if  (and m n)
     
615.       (mapcar '(lambda (a b) (apply 'mapcar (cons a b)))
     
616.         '(min max)
     
617.         (list m n)
     
618.       )
     
619.     )
     
620.   )
     
621.   (if (setq box (LM:ssboundingbox sel))
     
622.     (progn
     
623.       (setq app  (vlax-get-acad-object)
     
624.       dis  (/ (apply 'distance box) 20.0)
     
625.       lst  (mapcar  '(lambda (a o) (mapcar o a (list dis dis)))
     
626.       box
     
627.       '(- +)
     
628.     )
     
629.       are  (apply '* (apply 'mapcar (cons '- (reverse lst))))
     
630.       dis  (* dis 1.5)
     
631.       ent
     
632.     (entmakex
     
633.       (append
     
634.         '((000 . "LWPOLYLINE")
     
635.           (100 . "AcDbEntity")
     
636.           (100 . "AcDbPolyline")
     
637.           (090 . 4)
     
638.           (070 . 1)
     
639.          )
     
640.         (mapcar '(lambda (x)
     
641.              (cons 10 (mapcar '(lambda (y) ((eval y) lst)) x))
     
642.            )
     
643.           '((caar cadar)
     
644.             (caadr cadar)
     
645.             (caadr cadadr)
     
646.             (caar cadadr)
     
647.            )
     
648.         )
     
649.       )
     
650.     )
     
651.       )
     
652.       (apply
     
653.   'vlax-invoke
     
654.   (vl-list* app
     
655.       'zoomwindow
     
656.       (mapcar '(lambda (a o) (mapcar o a (list dis dis 0.0)))
     
657.         box
     
658.         '(- +)
     
659.       )
     
660.   )
     
661.       )
     
662.       (setq cmd  (getvar 'cmdecho)
     
663.       enl  (entlast)
     
664.       rtn  (ssadd)
     
665.       )
     
666.       (while (setq tmp (entnext enl)) (setq enl tmp))
     
667.       (setvar 'cmdecho 0)
     
668.       (command
     
669.   "_.-boundary"
     
670.   "_a"
     
671.   "_b"
     
672.   "_n"
     
673.   sel
     
674.   ent
     
675.   ""
     
676.   "_i"
     
677.   "_y"
     
678.   "_o"
     
679.   "_p"
     
680.   ""
     
681.   (trans (mapcar '- (car box) (list (/ dis 3.0) (/ dis 3.0)))
     
682.          0
     
683.          1
     
684.   )
     
685.   ""
     
686.       )
     
687.       (while (< 0 (getvar 'cmdactive)) (command ""))
     
688.       (entdel ent)
     
689.       (while (setq enl (entnext enl))
     
690.   (if (and (vlax-property-available-p
     
691.        (setq obj (vlax-ename->vla-object enl))
     
692.        'area
     
693.      )
     
694.      (equal (vla-get-area obj) are 1e-4)
     
695.       )
     
696.     (entdel enl)
     
697.     (ssadd enl rtn)
     
698.   )
     
699.       )
     
700.       (vla-zoomprevious app)
     
701.       (setvar 'cmdecho cmd)
     
702.       rtn
     
703.     )
     
704.   )
     
705. )
     
706. 
     
707. ;(LM:outline(ssget))
     
708. 
     
709. (defun PoInPl(pt lst / i p1 p2 an anl ret)
     
710.     (setq i -1 p1 (last lst))
     
711.     (while(and(not ret)(setq p2(nth(setq i(1+ i))lst)))
     
712.       (cond((equal p2 pt 1e-6)(setq ret t))
     
713.      (t(setq an(-(angle pt p1)(angle pt p2)))
     
714.       (if(equal pi(abs an) 1e-6)
     
715.         (setq ret t)
     
716.         (setq anl(cons(rem an PI)anl)))))
     
717.       (setq p1 p2))
     
718.     (cond(ret 0);线上;
     
719.    (t(if(equal PI(abs(apply'+ anl))1e-6)1 -1))))
     
720. 
     
721. 
     
722. (defun vxs(e / p a b n ob q et d d1 en et)
     
723.     (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
     
724.     (cond((="LWPOLYLINE"et)
     
725.     (repeat(length a)(setq b (nth n a) n (+ n 1))
     
726.       (if (= 10 (car b))(progn
     
727.         (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
     
728.         (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
     
729.           (setq p (list q)))))))
     
730.    ((="OLYLINE"et)
     
731.     (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
     
732.     (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
     
733.       (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
     
734.       (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
     
735.       (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
     
736.     (setq p(reverse p))))P)
     
737. ;;;;;;;;;;
     
738. (vl-load-com)
     
739. (defun c:dmfc (  / zxbl pt p1 p2 p3 p4  fchd lst gcz nn i ss  p5 ssa);
     
740. (setq fchd (getreal "\n请输入回填土压实后厚度(一般0.25米) :"))
     
741. (setq zxbl (getint "\n请输入断面纵向比例 1 :"))
     
742.   (setq pt (getpoint "\n请点击横断面图上96区顶中桩位置 :"))
     
743. (setq p1 (car(entsel "\n请选择96区顶横断面多段线：")))
     
744.   (setq p2 (car(entsel "\n请选择左边坡断面多段线：")))
     
745.   (setq p3 (car(entsel "\n请选择右边坡横断面多段线：")))
     
746.   (setq p4 (car(entsel "\n请选择原地面横断面多段线：")))
     
747.   (setq ss(ssadd)) (ssadd p1 ss)(ssadd p2 ss)(ssadd p3 ss)(ssadd p4 ss)
     
748.   (LM:outline ss ) (setq p5 (entlast))
     
749. 
     
750. (setq lst (vl-sort (vxs p4)(function (lambda (e1 e2) (< (cadr e1) (cadr e2))))))
     
751. 
     
752. (setq gcz (* (- (cadr pt)  (cadr(car lst))  ) (/ zxbl 1000.000)  )  )
     
753. 
     
754. (setq nn (fix (/ gcz fchd)))
     
755. (setq i 0) (setvar "osmode" 16384) (setvar "CMDECHO" 0)
     
756. (repeat  (- nn 1)
     
757.   
     
758. (command "_.copy" p1 "" pt (polar pt (* 1.5 pi ) (/ (* fchd (+ i 1)) (/ zxbl 1000.000)  )   )   "" )
     
759.   ;
     
760.   (command "_.extend"  p2   "" (list  (entlast)(car(vxs (entlast)))) "" )
     
761.   (command "_.extend"  p2   "" (list (entlast) (last(vxs (entlast))) ) "" )
     
762. 
     
763.   (command "_.extend"  p3   "" (list  (entlast)(car(vxs (entlast)))) "" )
     
764.   (command "_.extend"  p3   "" (list (entlast) (last(vxs (entlast))) ) "" )
     
765. (command "_.extend"  p4   "" (list  (entlast)(car(vxs (entlast)))) "" )
     
766.   (command "_.extend"  p4   "" (list (entlast) (last(vxs (entlast))) ) "" )
     
767.      
     
768. (setq i (1+ i))
     
769.   )  (setvar "osmode" 16384) (setvar "CMDECHO" 0)
     
770.   ;(TrimByFence0 (GetListOfPline0 p5))
     
771. ;(entdel p5)
     
772.    (pzx-extrim p5  (polar pt (* 0.5 pi ) (/ (* fchd 3) (/ zxbl 1000.000)  )   ) )
     
773. 
     
774. (setvar "osmode" 9) (setvar "CMDECHO" 1)
     
775. (princ)
     
776.   )

;;<br /> ;;;<br /> ;;;    EXTRIM.LSP<br /> ;;;    Copyright ?1999 by Autodesk, Inc.<br /> ;;;<br /> ;;;    Your use of this software is governed by the terms and conditions of the<br /> ;;;    License Agreement you accepted prior to installation of this software.<br /> ;;;    Please note that pursuant to the License Agreement for this software,<br /> ;;;    "[c]opying of this computer program or its documentation except as<br /> ;;;    permitted by this License is copyright infringement under the laws of<br /> ;;;    your country.  If you copy this computer program without permission of<br /> ;;;    Autodesk, you are violating the law."<br /> ;;;<br /> ;;;    AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.<br /> ;;;    AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF<br /> ;;;    MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK, INC.<br /> ;;;    DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE<br /> ;;;    UNINTERRUPTED OR ERROR FREE.<br /> ;;;<br /> ;;;    Use, duplication, or disclosure by the U.S. Government is subject to<br /> ;;;    restrictions set forth in FAR 52.227-19 (Commercial Computer<br /> ;;;    Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)<br /> ;;;    (Rights in Technical Data and Computer Software), as applicable.<br /> ;;;<br /> ;;;  ----------------------------------------------------------------<br /> <br /> <br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> ;Extended-TRIM - cookie-cutter routine<br /> ;<br /> ;Select a polyline, line, circle or arc and a side to trim on<br /> ;<br /> (defun pzx-extrim (na p1 / na e1 p1 redraw_it lst n )<br /> <br /> (acet-error-init (list<br />                    (list   "cmdecho" 0<br />                          "highlight" 0<br />                          "regenmode" 1<br />                             "osmode" 0<br />                            "ucsicon" 0<br />                         "offsetdist" 0<br />                             "attreq" 0<br />                           "plinewid" 0<br />                          "plinetype" 1<br />                           "gridmode" 0<br />                            "celtype" "CONTINUOUS"<br />                          "ucsfollow" 0<br />                           "limcheck" 0<br />                    )<br />                    T     ;flag. True means use undo for error clean up.<br />                    '(if redraw_it (redraw na 4))<br />                   );list<br /> );acet-error-init<br /> <br /> <br /> (princ "\nPick a POLYLINE, LINE, CIRCLE, ARC, ELLIPSE, IMAGE or TEXT for cutting edge...")<br /> ;setq<br /> (if na<br />     (progn<br />      (setq e1 (entget na));;setq<br />      (if (or (equal "TEXT"   (cdr (assoc 0 e1)))<br />              (equal "MTEXT"  (cdr (assoc 0 e1)))<br />              (equal "ATTDEF" (cdr (assoc 0 e1)))<br />              (equal "IMAGE"  (cdr (assoc 0 e1)))<br />              (equal "INSERT" (cdr (assoc 0 e1)))<br />              (equal "SOLID"  (cdr (assoc 0 e1)))<br />              (equal "3DFACE" (cdr (assoc 0 e1)))<br />              (equal "TRACE"  (cdr (assoc 0 e1)))<br />          );or<br />          (progn<br />           (setq lst (acet-geom-object-point-list na nil))<br />           (setq n 0)<br />           (command "_.pline")<br />           (repeat (length lst)<br />           (command (nth n lst))<br />           (setq n (+ n 1));setq<br />           );repeat<br />           (if (not (equal (car lst) (last lst) 0.0000001))<br />               (command "_cl")<br />               (command "")<br />           );if<br />           (setq na (entlast)<br />                 e1 na<br />           );setq<br />          );progn then draw a temp pline to be the cutting edge.<br />          (setq e1 nil)<br />      );if<br />      (redraw na 3)<br />      (setq redraw_it T)<br /> <br />      ;setq<br />      (redraw na 4)<br />      (setq redraw_it nil)<br />      (if p1 (etrim na p1));if<br />      (if e1<br />          (progn<br />           (if (setq p1 (acet-layer-locked (getvar "clayer")))<br />               (command "_.layer" "_un" (getvar "clayer") "")<br />           );if<br />           (entdel e1)<br />           (if p1<br />               (command "_.layer" "_lock" (getvar "clayer") "")<br />           );if<br />          );progn then<br />      );if<br />     );progn<br /> );if<br /> <br /> (acet-error-restore)<br /> (princ)<br /> );defun c:extrim<br /> <br /> ;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!<br /> ;Entity-TRIM function<br /> ;takes: na - entity name<br /> ;  a - a point, the side to trim on<br /> ;NOTE: This function does not allow for the possible miss of<br /> ;      non-continuous linetypes.<br /> ;<br /> (defun etrim ( na a / la b d e1 lst lst2 n j k m ss na2 na3 na4<br />                       x y z flag flag2 flag3 zlst vpna vplocked<br />              )<br /> <br /> <br /> (setq e1 (entget na));setq<br /> (if (or (setq flag (equal (acet-dxf 0 e1) "<img src="static/image/smiley/default/titter.gif" smilieid="9" border="0" alt="" />OLYLINE"))<br />         (setq flag (equal (acet-dxf 0 e1) "LWPOLYLINE"))<br />         (equal (acet-dxf 0 e1) "LINE")<br />         (equal (acet-dxf 0 e1) "CIRCLE")<br />         (equal (acet-dxf 0 e1) "ARC")<br />         (equal (acet-dxf 0 e1) "ELLIPSE")<br />         (equal (acet-dxf 0 e1) "TEXT")<br />         (equal (acet-dxf 0 e1) "ATTDEF")<br />         (equal (acet-dxf 0 e1) "MTEXT")<br />         (equal (acet-dxf 0 e1) "SPLINE")<br />     );or<br />     (progn<br />      (if (and flag<br />               (equal 8 (logand 8 (acet-dxf 70 e1)))<br />          );and<br />          (setq flag nil)<br />      );if<br />      (setq     a (trans a 1 0)<br />             vpna (acet-currentviewport-ename)<br />      );setq<br />      (acet-ucs-cmd (list "_View"))<br /> <br />      (setq   lst (acet-geom-object-point-list na nil)  ;;;find extents of selected cutting edge object<br />              lst (acet-geom-list-extents lst)<br />                x (- (car (cadr lst)) (car (car lst)))<br />                y (- (cadr (cadr lst)) (cadr (car lst)))<br />                x (* 0.075 x)<br />                y (* 0.075 y)<br />                z (list x y)<br />                x (list (+ (car (cadr lst)) (car z))<br />                        (+ (cadr (cadr lst)) (cadr z))<br />                  );list<br />                y (list (- (car (car lst)) (car z))<br />                        (- (cadr (car lst)) (cadr z))<br />                  );list<br />             zlst (zoom_2_object (list x y))<br />      );setq<br />      (if vpna<br />          (setq vplocked (acet-viewport-lock-set vpna nil)) ;unlock cur viewport if needed.<br />      );if<br />      (command "_.zoom" "_w" (car zlst) (cadr zlst))<br /> <br />      (entupd na)                  ;;;update the ent. so it's curves display smoothly<br /> <br />      (setq lst (acet-geom-object-point-list na<br />                        (/ (acet-geom-pixel-unit) 2.0)<br />                )<br />      );setq<br />      (if (or (not flag)<br />              (not (acet-geom-self-intersect lst nil))<br />          );or<br />          (progn             ;then the object is valid and not a self intersecting polyline.<br />           (if (and flag<br />                    (equal (car lst) (last lst) 0.0001)<br />               );and<br />               (setq flag3 T);then the polyline could potentialy need a second offset<br />           );if<br />           (if (setq la (acet-layer-locked (getvar "clayer")))<br />               (command "_.layer" "_unl" (getvar "clayer") "")<br />           );if<br /> <br />           (command "_.pline")<br />           (setq b nil)<br />           (setq n 0);setq<br />           (repeat (length lst)<br />            (setq d (nth n lst))<br />            (if (not (equal d b 0.0001))<br />               (progn<br />                (command d)<br />                (setq lst2 (append lst2 (list d)));setq<br />                (setq b d);setq<br />               );progn<br />            );if<br />            (setq n (+ n 1))<br />           );repeat<br />           (command "")<br />           (setq  na2 (entlast)<br />                   ss (ssadd)<br />                   ss (ssadd na2 ss)<br />                  lst nil<br />           );setq<br />           (acet-ss-visible ss 1)<br />           (setq lst2 (get_fence_points na2 a lst2 flag3 flag));setq<br /> <br />           (if la<br />               (command "_.layer" "_lock" (getvar "clayer") "")<br />           );if<br />           (acet-ucs-cmd (list "_p"))<br />           ;Move the ents to force a display update of the ents to avoid viewres problems.<br />           (setvar "highlight" 0)<br />           (if (setq ss (ssget "_f" (last lst2)))<br />               (command "_.move" ss "" "0,0,0" "0,0,0")<br />           );if<br />           (if flag<br />               (progn<br />                (if (setq la (acet-layer-locked (acet-dxf 8 e1)))<br />                    (command "_.layer" "_unl" (acet-dxf 8 e1) "")<br />                );if<br />                (acet-ucs-set-z (acet-dxf 210 e1))<br />                (command "_.copy" na "" "0,0,0" "0,0,0")<br />                ;(entdel na)<br />                (acet-ss-visible (ssadd na (ssadd)) 1);make it invisible for a while.<br />                                                     ;rk 12:01 PM 3/10/98<br />                (setq na3 na<br />                       na (entlast)<br />                );setq<br />                (command "_.pedit" na "_w" "0.0" "_x")<br />                (acet-ucs-cmd (list "_p"))<br />                (if la (command "_.layer" "_lock" (acet-dxf 8 e1) ""));if<br />               );progn<br />           );if<br />           (command "_.trim" na "")<br />           (setq m (- (length lst2) 1));setq<br />           (setq k 0)<br />           (repeat (length lst2)<br />            (setq lst (nth k lst2))<br />            (setq a (trans (car lst) 0 1))<br />            (setq n 1)<br />            (repeat (- (length lst) 1) ;repeat each fence list<br />             (setq b (trans (nth n lst) 0 1))<br />             (if (equal a b 0.0001)<br />                 (setq flag2 T)<br />                 (setq flag2 nil)<br />             );if<br />             (setq na4 nil);setq<br />             (setq j 0);setq<br />             (while (not flag2)       ;repeat each segment of the fence until no new ents are created.<br />              (setq na4 (entlast));setq<br />              (command "_F" a b "")<br />              (if (and (equal na4 (entlast))<br />                       (or (not (equal k m))<br />                           (> j 0)<br />                       );or<br />                  );and<br />                  (setq flag2 T)<br />              );if<br />              (setq j (+ j 1));setq<br />             );while<br />             (setq a b);setq<br />             (setq n (+ n 1));setq<br />            );repeat<br /> <br />            (setq k (+ k 1))<br />           );repeat<br />           (command "")<br /> <br />           (if flag<br />               (progn<br />                (if (setq la (acet-layer-locked (acet-dxf 8 e1)))<br />                    (command "_.layer" "_unl" (acet-dxf 8 e1) "")<br />                );if<br />                (entdel na) ;get rid of the copy<br /> <br />                ;(entdel na3);bring back the original<br />                (acet-ss-visible (ssadd na3 (ssadd)) 0) ;bring back the original<br />                                                       ;rk 12:01 PM 3/10/98<br />                (if la (command "_.layer" "_lock" (acet-dxf 8 e1) ""));if<br />               );progn<br />           );if<br />          );progn<br />          (progn<br />           (acet-ucs-cmd (list "_p"))<br />           (princ "\nSelf intersecting edges are not acceptable.")<br />          );progn else invalid self intersecting polyline<br />      );if<br />      (command "_.zoom" "_p")<br />      (if vplocked<br />          (acet-viewport-lock-set vpna T) ;then re-lock the viewport<br />      );if<br />     );progn then it's a most likely a valid entity.<br /> );if<br /> );defun etrim<br /> <br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> (defun another_offset ( pl1 pl2 a1 a2 b na2 lst2 a lst3 lst4 / na ss lst da1 da2)<br /> <br /> (setq da1 (abs (- a2 a1)));setq<br /> (setq da2 (- (* b (max pl2 pl1))<br />              (/ (* b (abs (- pl2 pl1)))<br />                  2.0<br />              )<br />           )<br /> );setq<br /> (if (> (abs (- da2 da1))<br />        (* 0.01 (max a1 a2))<br />     )<br />     (progn<br /> <br />      (acet-pline-make (list lst2))<br />      (setq  na (entlast)<br />            na2 (entlast)<br />             ss (ssadd)<br />             ss (ssadd na ss)<br />      );setq<br />      (acet-ss-visible ss 1)<br />      (command "_.offset" b na2 a "")<br />      (if (and (not (equal na (entlast)))<br />               (setq lst3 (acet-geom-vertex-list (entlast)))<br />               (setq lst3 (intersect_check lst2 lst3 lst4))<br />          );and<br />          (progn<br />           (acet-ss-visible (ssadd (entlast) (ssadd)) 1)<br />           (command "_.area" "_ob" (entlast))<br />           (setq pl2 (getvar "perimeter")<br />                  a2 (getvar "area")<br />           );setq<br />           (setq lst (list (acet-geom-vertex-list (list (entlast) 0))));setq<br />           (entdel (entlast));then offset was a success so delete the ent after getting it's info<br />          );progn then<br />          (if (not (equal na (entlast))) (entdel (entlast)));if else<br />      );if<br />      (entdel na2)<br />     );progn then let's do that second offset<br /> );if<br /> <br /> lst<br /> );defun another_offset<br /> <br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> (defun get_fence_points ( na2 a lst2 flag plflag / a1 a2 pl1 pl2 b c d n<br />                                                    lst lst2 lst3 lst4 na<br />                         )<br /> <br /> (if flag<br />     (progn<br />      (setq lst2 (cdr lst2));setq<br />      (repeat (fix (/ (length lst2) 2))<br />       (setq lst2 (append (cdr lst2) (list (car lst2)));append<br />       );setq<br />      );repeat<br />      (setq lst2 (append lst2 (list (car lst2))));setq<br />      (command "_.area" "_ob" na2)<br />      (setq pl1 (getvar "perimeter")<br />             a1 (getvar "area")<br />      );setq<br />     );progn<br /> );if<br /> <br /> (setq    a (trans a 0 1)<br />          b (* (getvar "viewsize") 0.05);initial offset distance<br />          n 3.0                         ;number of offsets<br />          d (/ b (- n 1))               ;delta offset<br />          c (acet-geom-pixel-unit)<br />       lst4 (acet-geom-view-points)<br /> );setq<br /> <br /> (while (> b c)<br /> (setq na (entlast))<br /> (command "_.offset" b na2 a "")<br /> (if (and (not (equal na (entlast)))<br />          (setq lst3 (acet-geom-vertex-list (entlast)))<br />          (or (not plflag)<br />              (setq lst3 (intersect_check lst2 lst3 lst4))<br />          );or<br />     );and<br />     (progn<br />      (setq lst3 (acet-geom-m-trans lst3 1 0))<br />      (acet-ss-visible (ssadd (entlast) (ssadd)) 1)<br />      (if flag<br />          (progn<br />           (command "_.area" "_ob" (entlast))<br />           (setq pl2 (getvar "perimeter")<br />                  a2 (getvar "area")<br />           );setq<br />          );progn<br />      );if<br />      (setq lst (append lst (list lst3)));setq<br />      (entdel (entlast))  ;delete the ent after getting it's vertex info<br />      (if flag<br />          (setq lst (append lst<br />                            (another_offset pl1 pl2 a1 a2 b na2 lst2 a lst3 lst4)<br />                    );append<br />          );setq<br />      );if<br />     );progn then offset was a success<br />     (if (not (equal na (entlast))) (entdel (entlast)));if else<br /> );if<br /> (setq b (- b d));setq<br /> );while<br /> (setq na (entlast))<br /> (command "_.offset" c na2 a "")<br /> (if (and (not (equal na (entlast)))<br />          (setq lst3 (acet-geom-vertex-list (entlast)))<br />          (or (not plflag)<br />              (setq lst3 (intersect_check lst2 lst3 lst4))<br />          );or<br />     );and<br />     (progn<br />      (setq lst3 (acet-geom-m-trans lst3 1 0))<br />      (acet-ss-visible (ssadd (entlast) (ssadd)) 1)<br />      (if flag<br />          (progn<br />           (command "_.area" "_ob" (entlast))<br />           (setq pl2 (getvar "perimeter")<br />                  a2 (getvar "area")<br />           );setq<br />          );progn<br />      );if<br />      (setq lst (append lst (list lst3)));setq<br />      (entdel (entlast));then offset was a success so delete the ent after getting it's info<br />      (if flag<br />          (setq lst (append lst<br />                            (another_offset pl1 pl2 a1 a2 c na2 lst2 a lst3 lst4)<br />                    );append<br />          );setq<br />      );if<br />     );progn then<br />     (if (not (equal na (entlast))) (entdel (entlast)));if else<br /> );if<br /> (entdel na2)<br /> <br /> lst<br /> );defun get_fence_points<br /> <br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> ;returns a list of points on screen if the first two lists do not<br /> ;contain segments that intersect each other.<br /> ;<br /> (defun intersect_check ( lst lst2 lst3 / x x2 y y2 lst4 flag len len2<br />                                          a aa b bb c d n j)<br /> <br /> (setq  len (length lst)<br />       len2 (length lst2)<br />          x (car (car lst3))<br />         x2 (car (cadr lst3))<br />          y (cadr (car lst3))<br />         y2 (cadr (cadr lst3))<br /> );setq<br /> <br /> (setq n 0);setq<br /> (while (and (not flag)<br />             (< (+ n 1) len2)<br />        );and<br /> (setq   aa (nth n lst2)<br />         bb (nth (+ n 1) lst2)<br />          a (bns_truncate_2_view aa bb x y x2 y2)<br />          b (bns_truncate_2_view bb aa x y x2 y2)<br />       lst4 (append lst4 (list a))<br /> );setq<br /> (if (or (not (equal a aa))<br />         (not (equal b bb))<br />     );or<br />     (setq lst4 (append lst4 (list b)))<br /> );if<br /> (setq j 0);setq<br /> (while (and (not flag)<br />              (< (+ j 1) len)<br />         );and<br /> (setq    c (nth j lst)<br />           d (nth (+ j 1) lst)<br />        flag (inters a b c d)<br /> );setq<br /> <br /> (setq j (+ j 1));setq<br /> );while<br /> <br /> (setq n (+ n 1));setq<br /> );while<br /> (if (not (equal b (last lst4)))<br />     (setq lst4 (append lst4 (list b)));setq<br /> );if<br /> (if (not flag)<br />     (setq flag lst4)<br />     (setq flag nil)<br /> );if<br /> flag<br /> );defun intersect_check<br /> <br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> (defun zoom_2_object ( lst / p1 p2 p3 p4 p5 p6 mp dx dy dx2 dy2<br />                              r1 r2 na e1 x w h dv1 dv2 x<br />                      )<br /> <br /> (setq  lst (acet-geom-m-trans lst 1 2)<br />          p1 (acet-geom-m-trans (acet-geom-view-points) 1 2)    ;p1 and p2 are the viewpnts<br />          p2 (cadr p1)<br />          p1 (car p1)<br />          p1 (list (car p1) (cadr p1))<br />          p2 (list (car p2) (cadr p2))<br /> );setq<br /> (if lst<br />      (progn<br />       (setq   p5 (acet-geom-list-extents lst)              ;p5 and p6 are the geometry points<br />               p6 (cadr p5)<br />               p5 (car p5)<br />               p5 (list (car p5) (cadr p5))<br />               p6 (list (car p6) (cadr p6))<br />               mp (acet-geom-midpoint p5 p6)           ;prepare to resize the geometry rectang to<br />               dx (- (car p2) (car p1))    ;have the same dy/dx ratio as p1 p2.<br />               dy (- (cadr p2) (cadr p1))<br />              dx2 (- (car p6) (car p5))<br />              dy2 (- (cadr p6) (cadr p5))<br />       );setq<br />       (if (equal dx 0.0)  (setq dx 0.000001))  ;just in case div by zero<br />       (if (equal dx2 0.0) (setq dx2 0.000001))<br />       (setq   r1 (/ dy dx)<br />               r2 (/ dy2 dx2)<br />       );setq<br />       (if (< r2 r1)<br />           (setq dy2 (* r1 dx2));then scale dy2 up<br />           (progn<br />            (if (equal r1 0.0)  (setq r1 0.000001))  ;just in case div by zero<br />            (setq dx2 (* dy2 (/ 1.0 r1)));else scale dx2 up<br />           );progn<br />       );if<br />       (setq p5 (list (- (car mp) (/ dx2 1.98))   ;1.98 is used instead of 2.0 to expand<br />                      (- (cadr mp) (/ dy2 1.98))  ;the rectangle slightly<br />                );list<br />             p6 (list (+ (car mp) (/ dx2 1.98))<br />                      (+ (cadr mp) (/ dy2 1.98))<br />                );list<br />       );setq<br />      );progn then lst<br /> );if<br /> (if (and lst<br />           (equal 0 (getvar "tilemode"))<br />           (not (equal 1 (getvar "cvport")))<br />           (setq na (acet-currentviewport-ename))<br />      );and<br />      (progn<br />       (setq  e1 (entget na)<br />               x (cdr (assoc 10 e1))<br />               w (cdr (assoc 40 e1))<br />               h (cdr (assoc 41 e1))<br />              p3 (list (- (car x) (/ w 2.0))<br />                       (- (cadr x) (/ h 2.0))<br />                 );list<br />              p4 (list (+ (car x) (/ w 2.0))<br />                       (+ (cadr x) (/ h 2.0))<br />                 );list<br />              p3 (trans p3 3 2)      ;p3 and p4 are the viewport points<br />              p4 (trans p4 3 2)<br />             dv1 (acet-geom-delta-vector p1 p3)<br />             dv2 (acet-geom-delta-vector p2 p4)<br />               x (distance p1 p2)<br />       );setq<br />       (if (equal 0 x) (setq x 0.000001));just in case<br />       (setq   x (/ (distance p5 p6)<br />                    x<br />                 )<br />             dv1 (acet-geom-vector-scale dv1 x)<br />             dv2 (acet-geom-vector-scale dv2 x)<br />              p5 (acet-geom-vector-add p5 dv1)<br />              p6 (acet-geom-vector-add p6 dv2)<br />        );setq<br />      );progn then<br /> );if<br /> (setq p1 (list (car p1) (cadr p1) 0.0)<br />        p2 (list (car p2) (cadr p2) 0.0)<br />        p5 (list (car p5) (cadr p5) 0.0)<br />        p6 (list (car p6) (cadr p6) 0.0)<br /> );setq<br /> (if lst<br />      (setq lst (list (trans p5 2 1)<br />                      (trans p6 2 1)<br />                );list<br />      );setq<br />      (setq lst nil)<br /> );if<br /> <br /> lst<br /> );defun zoom_2_object<br /> <br /> <br /> (princ)<br /> <br /> ;;;;;;;;;;;;;;;;<br /> (defun LM:outline (sel      /       LM:ssboundingbox  app<br />        are      box       cmd      dis      enl<br />        ent      lst       obj      rtn      tmp<br />       )<br />   (defun LM:ssboundingbox (s / a b i m n o)<br />     (repeat (setq i (sslength s))<br />       (if<br />   (and<br />     (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))<br />     (vlax-method-applicable-p o 'getboundingbox)<br />     (not<br />       (vl-catch-all-error-p<br />         (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))<br />       )<br />     )<br />   )<br />    (setq m (cons (vlax-safearray->list a) m)<br />          n (cons (vlax-safearray->list b) n)<br />    )<br />       )<br />     )<br />     (if  (and m n)<br />       (mapcar '(lambda (a b) (apply 'mapcar (cons a b)))<br />         '(min max)<br />         (list m n)<br />       )<br />     )<br />   )<br />   (if (setq box (LM:ssboundingbox sel))<br />     (progn<br />       (setq app  (vlax-get-acad-object)<br />       dis  (/ (apply 'distance box) 20.0)<br />       lst  (mapcar  '(lambda (a o) (mapcar o a (list dis dis)))<br />       box<br />       '(- +)<br />     )<br />       are  (apply '* (apply 'mapcar (cons '- (reverse lst))))<br />       dis  (* dis 1.5)<br />       ent<br />     (entmakex<br />       (append<br />         '((000 . "LWPOLYLINE")<br />           (100 . "AcDbEntity")<br />           (100 . "AcDbPolyline")<br />           (090 . 4)<br />           (070 . 1)<br />          )<br />         (mapcar '(lambda (x)<br />              (cons 10 (mapcar '(lambda (y) ((eval y) lst)) x))<br />            )<br />           '((caar cadar)<br />             (caadr cadar)<br />             (caadr cadadr)<br />             (caar cadadr)<br />            )<br />         )<br />       )<br />     )<br />       )<br />       (apply<br />   'vlax-invoke<br />   (vl-list* app<br />       'zoomwindow<br />       (mapcar '(lambda (a o) (mapcar o a (list dis dis 0.0)))<br />         box<br />         '(- +)<br />       )<br />   )<br />       )<br />       (setq cmd  (getvar 'cmdecho)<br />       enl  (entlast)<br />       rtn  (ssadd)<br />       )<br />       (while (setq tmp (entnext enl)) (setq enl tmp))<br />       (setvar 'cmdecho 0)<br />       (command<br />   "_.-boundary"<br />   "_a"<br />   "_b"<br />   "_n"<br />   sel<br />   ent<br />   ""<br />   "_i"<br />   "_y"<br />   "_o"<br />   "_p"<br />   ""<br />   (trans (mapcar '- (car box) (list (/ dis 3.0) (/ dis 3.0)))<br />          0<br />          1<br />   )<br />   ""<br />       )<br />       (while (< 0 (getvar 'cmdactive)) (command ""))<br />       (entdel ent)<br />       (while (setq enl (entnext enl))<br />   (if (and (vlax-property-available-p<br />        (setq obj (vlax-ename->vla-object enl))<br />        'area<br />      )<br />      (equal (vla-get-area obj) are 1e-4)<br />       )<br />     (entdel enl)<br />     (ssadd enl rtn)<br />   )<br />       )<br />       (vla-zoomprevious app)<br />       (setvar 'cmdecho cmd)<br />       rtn<br />     )<br />   )<br /> )<br /> <br /> ;(LM:outline(ssget))<br /> <br /> (defun PoInPl(pt lst / i p1 p2 an anl ret)<br />     (setq i -1 p1 (last lst))<br />     (while(and(not ret)(setq p2(nth(setq i(1+ i))lst)))<br />       (cond((equal p2 pt 1e-6)(setq ret t))<br />      (t(setq an(-(angle pt p1)(angle pt p2)))<br />       (if(equal pi(abs an) 1e-6)<br />         (setq ret t)<br />         (setq anl(cons(rem an PI)anl)))))<br />       (setq p1 p2))<br />     (cond(ret 0);线上;<br />    (t(if(equal PI(abs(apply'+ anl))1e-6)1 -1))))<br /> <br /> <br /> (defun vxs(e / p a b n ob q et d d1 en et)<br />     (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)<br />     (cond((="LWPOLYLINE"et)<br />     (repeat(length a)(setq b (nth n a) n (+ n 1))<br />       (if (= 10 (car b))(progn<br />         (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))<br />         (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))<br />           (setq p (list q)))))))<br />    ((="<img src="static/image/smiley/default/titter.gif" smilieid="9" border="0" alt="" />OLYLINE"et)<br />     (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))<br />     (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")<br />       (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))<br />       (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))<br />       (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))<br />     (setq p(reverse p))))P)<br /> ;;;;;;;;;;<br /> (vl-load-com)<br /> (defun c:dmfc (  / zxbl pt p1 p2 p3 p4  fchd lst gcz nn i ss  p5 ssa);<br /> (setq fchd (getreal "\n请输入回填土压实后厚度(一般0.25米) :"))<br /> (setq zxbl (getint "\n请输入断面纵向比例 1 :"))<br />   (setq pt (getpoint "\n请点击横断面图上96区顶中桩位置 :"))<br /> (setq p1 (car(entsel "\n请选择96区顶横断面多段线：")))<br />   (setq p2 (car(entsel "\n请选择左边坡断面多段线：")))<br />   (setq p3 (car(entsel "\n请选择右边坡横断面多段线：")))<br />   (setq p4 (car(entsel "\n请选择原地面横断面多段线：")))<br />   (setq ss(ssadd)) (ssadd p1 ss)(ssadd p2 ss)(ssadd p3 ss)(ssadd p4 ss)<br />   (LM:outline ss ) (setq p5 (entlast))<br /> <br /> (setq lst (vl-sort (vxs p4)(function (lambda (e1 e2) (< (cadr e1) (cadr e2)))))) <br /> <br /> (setq gcz (* (- (cadr pt)  (cadr(car lst))  ) (/ zxbl 1000.000)  )  )<br /> <br /> (setq nn (fix (/ gcz fchd)))<br /> (setq i 0) (setvar "osmode" 16384) (setvar "CMDECHO" 0)<br /> (repeat  (- nn 1)<br />   <br /> (command "_.copy" p1 "" pt (polar pt (* 1.5 pi ) (/ (* fchd (+ i 1)) (/ zxbl 1000.000)  )   )   "" )<br />   ;<br />   (command "_.extend"  p2   "" (list  (entlast)(car(vxs (entlast)))) "" )<br />   (command "_.extend"  p2   "" (list (entlast) (last(vxs (entlast))) ) "" )<br /> <br />   (command "_.extend"  p3   "" (list  (entlast)(car(vxs (entlast)))) "" )<br />   (command "_.extend"  p3   "" (list (entlast) (last(vxs (entlast))) ) "" )<br /> (command "_.extend"  p4   "" (list  (entlast)(car(vxs (entlast)))) "" )<br />   (command "_.extend"  p4   "" (list (entlast) (last(vxs (entlast))) ) "" )<br />      <br /> (setq i (1+ i)) <br />   )  (setvar "osmode" 16384) (setvar "CMDECHO" 0)<br />   ;(TrimByFence0 (GetListOfPline0 p5))<br /> ;(entdel p5)<br />    (pzx-extrim p5  (polar pt (* 0.5 pi ) (/ (* fchd 3) (/ zxbl 1000.000)  )   ) )<br /> <br /> (setvar "osmode" 9) (setvar "CMDECHO" 1)<br /> (princ)<br />   )

hncjddd

树櫴希德 发表于 2019-12-30 22:21
旧版有问题

非常棒的创新。。。。。。。

672277923

大神你好，我不会lisp，我一直用的VBA，我也想做一个CAD提取分层线信息到Excel以便于参与水准以及坐标的计算的小插件，现在我遇到的问题是没办法再次延伸或者剪切掉重新生成的多段线，卡住了，如果用纯数学的方式判断有点复杂。能帮我看看吗？我的代码如下：

1. Sub zcx()
   
2. Dim i As Long
   
3. Dim j As Long
   
4. Dim ch As Double
   
5. ch = ThisDrawing.Utility.GetReal("请输入层厚:")
   
6. '定义路面中心点，每层中心点
   
7. Dim pt1 As Variant
   
8. Dim ptn(0 To 2) As Double
   
9. '定义结构层线；左右边坡线；地面线
   
10. Dim jgc As AcadLWPolyline
    
11. Dim zbp As Object
    
12. Dim ybp As Object
    
13. Dim dmx As Object
    
14. ThisDrawing.Utility.GetEntity jgc, pt1, "拾取结构层线（确保其为一根多段线）："
    
15. ThisDrawing.Utility.GetEntity zbp, pt1, "拾取左边坡："
    
16. ThisDrawing.Utility.GetEntity ybp, pt1, "拾取右边坡："
    
17. ThisDrawing.Utility.GetEntity dmx, pt1, "拾取地面线："
    
18. '求与边坡的交点
    
19. Dim zbpjd As Variant
    
20. Dim ybpjd As Variant
    
21. Dim dmjd As Variant
    
22. Dim fcx() As Double
    
23. Dim fch As Integer '分层的层号，从上到下为负1...负N层（倒数第一至倒数第N层）
    
24. 
    
25. '----先复制下移结构层----
    
26. j = 1
    
27. For i = 1 To (UBound(jgc.Coordinates) + 1) Step 2
    
28.     ReDim Preserve fcx(1 To (UBound(jgc.Coordinates) + 1))
    
29.     fcx(j) = jgc.Coordinates(i - 1)
    
30.     fcx(j + 1) = jgc.Coordinates(i) - ch
    
31.     j = j + 2
    
32. Next i
    
33. Set jgc = ThisDrawing.ModelSpace.AddLightWeightPolyline(fcx)
    
34. 
    
35. zbpjd = jgc.IntersectWith(zbp, acExtendThisEntity)
    
36. ybpjd = jgc.IntersectWith(ybp, acExtendThisEntity)
    
37. dmjd = jgc.IntersectWith(dmx, acExtendThisEntity)
    
38. 
    
39. '接下来我就不知道怎么延伸重新生成的多段线到边坡或者到地面线了能帮我看看吗？
    
40. 
    
41. Stop
    
42. End Sub
    
43. 
    

Sub zcx()<br /> Dim i As Long<br /> Dim j As Long<br /> Dim ch As Double<br /> ch = ThisDrawing.Utility.GetReal("请输入层厚:")<br /> '定义路面中心点，每层中心点<br /> Dim pt1 As Variant<br /> Dim ptn(0 To 2) As Double<br /> '定义结构层线；左右边坡线；地面线<br /> Dim jgc As AcadLWPolyline<br /> Dim zbp As Object<br /> Dim ybp As Object<br /> Dim dmx As Object<br /> ThisDrawing.Utility.GetEntity jgc, pt1, "拾取结构层线（确保其为一根多段线）："<br /> ThisDrawing.Utility.GetEntity zbp, pt1, "拾取左边坡："<br /> ThisDrawing.Utility.GetEntity ybp, pt1, "拾取右边坡："<br /> ThisDrawing.Utility.GetEntity dmx, pt1, "拾取地面线："<br /> '求与边坡的交点<br /> Dim zbpjd As Variant<br /> Dim ybpjd As Variant<br /> Dim dmjd As Variant<br /> Dim fcx() As Double<br /> Dim fch As Integer '分层的层号，从上到下为负1...负N层（倒数第一至倒数第N层）<br /> <br /> '----先复制下移结构层----<br /> j = 1<br /> For i = 1 To (UBound(jgc.Coordinates) + 1) Step 2<br />     ReDim Preserve fcx(1 To (UBound(jgc.Coordinates) + 1))<br />     fcx(j) = jgc.Coordinates(i - 1)<br />     fcx(j + 1) = jgc.Coordinates(i) - ch<br />     j = j + 2<br /> Next i<br /> Set jgc = ThisDrawing.ModelSpace.AddLightWeightPolyline(fcx)<br /> <br /> zbpjd = jgc.IntersectWith(zbp, acExtendThisEntity)<br /> ybpjd = jgc.IntersectWith(ybp, acExtendThisEntity)<br /> dmjd = jgc.IntersectWith(dmx, acExtendThisEntity)<br /> <br /> '接下来我就不知道怎么延伸重新生成的多段线到边坡或者到地面线了能帮我看看吗？<br /> <br /> Stop<br /> End Sub<br /> <br />

672277923

有挡墙的路基，选择起来更复杂，判断也比较复杂，路肩墙桩板墙或者路堤墙还要与边坡判断，我已经放弃了。谢谢

czb203

群主可以出一个工具箱了，

13648893846

好像写过一个提取到表的

f4800

楼主问啥每次发帖 后面都要带个问号？  

填方路基横断面自动分层？