[转贴]：跟据已有hatch生成hatch边界

秋枫

2. [font=courier]
   
3. ;;; HATCHB.LSP ver 1.6
   
4. ;;; Recreates hatch boundary by selecting a hatch
   
5. ;;; Boundary is created in current layer/color/linetype in WCS
   
6. ;;; By Jimmy Bergmark
   
7. ;;; Copyright (C) 1997-2002 JTB World, All Rights Reserved
   
8. ;;; Website: [url]www.jtbworld.com[/url] / [url]http://jtbworld.vze.com[/url]
   
9. ;;; E-mail: [email]info@jtbworld.com[/email] / [email]jtbworld@hotmail.com[/email]
   
10. ;;; 2000-02-12 - First release
    
11. ;;; 2000-03-27 - Counterclockwise arc's and ellipse's fixed
    
12. ;;;              Objects created joined to lwpolyline if possible
    
13. ;;;              Error-handling, undo of command
    
14. ;;;              Can handle PLINETYPE = 0,1,2
    
15. ;;; 2000-03-30 - Integrating hatchb and hatchb14
    
16. ;;;              Selection of many hatches
    
17. ;;;              Splines supported if closed.
    
18. ;;; 2001-04-02 - Fixed bug with entmake of line with no Z for r14
    
19. ;;; 2001-07-31 - Removed an irritating semicolon to enable polylines to be created.
    
20. ;;; 2001-10-04 - Changed mail and homepage so it's easy to find when new versions comes up.
    
21. ;;; Tested on AutoCAD r14, 2000, 2000i, 2002
    
22. ;;; should be working on older versions too.
    
23. 
    
24. (defun c:hatchb        (/            es               blay          ed1             ed2
    
25.                  loops1            bptf       part          et             noe
    
26.                  plist            ic               bul          nr             ang1
    
27.                  ang2            obj               *ModelSpace*             *PaperSpace*
    
28.                  space            cw               errexit          undox             olderr
    
29.                  oldcmdecho ss1               lastent          en1             en2
    
30.                  ss            lwp               list->variantArray    3dPoint->2dPoint
    
31.                  A2k            ent               i          ss2             knot-list
    
32.                  controlpoint-list     kn          cn             pos
    
33.                  xv
    
34.                 )
    
35.   (setq A2k (wcmatch (getvar "ACADVER") "15*"))
    
36.   (if A2k
    
37.     (defun list->variantArray (ptsList / arraySpace sArray)
    
38.       (setq arraySpace
    
39.              (vlax-make-safearray
    
40.                vlax-vbdouble
    
41.                (cons 0 (- (length ptsList) 1))
    
42.              )
    
43.       )
    
44.       (setq sArray (vlax-safearray-fill arraySpace ptsList))
    
45.       (vlax-make-variant sArray)
    
46.     )
    
47.   )
    
48.   (if A2k
    
49.     (defun 3dPoint->2dPoint (3dpt)
    
50.       (list (float (car 3dpt)) (float (cadr 3dpt)))
    
51.     )
    
52.   )
    
53.   (defun errexit (s) (princ "\nError:  ") (princ s) (restore))
    
54.   (defun undox ()
    
55.     (command "._ucs" "_p")
    
56.     (command "._undo" "_E")
    
57.     (setvar "cmdecho" oldcmdecho)
    
58.     (setq *error* olderr)
    
59.     (princ)
    
60.   )
    
61.   (setq        olderr        *error*
    
62.         restore        undox
    
63.         *error*        errexit
    
64.   )
    
65.   (setq oldcmdecho (getvar "cmdecho"))
    
66.   (setvar "cmdecho" 0)
    
67.   (command "._UNDO" "_BE")
    
68.   (if A2k
    
69.     (progn (vl-load-com)
    
70.            (setq *ModelSpace* (vla-get-ModelSpace
    
71.                                 (vla-get-ActiveDocument (vlax-get-acad-object))
    
72.                               )
    
73.                  *PaperSpace* (vla-get-PaperSpace
    
74.                                 (vla-get-ActiveDocument (vlax-get-acad-object))
    
75.                               )
    
76.            )
    
77.     )
    
78.   )                                        ; For testing purpose
    
79.                                         ; (setq A2k nil)
    
80.   (if (/= (setq ss2 (ssget '((0 . "HATCH")))) nil)
    
81.     (progn
    
82.       (setq i 0)
    
83.       (while (setq ent (ssname ss2 i))
    
84.         (setq ed1 (entget ent))
    
85.         (if (not (equal (assoc 210 ed1) '(210 0.0 0.0 1.0)))
    
86.           (princ "\nHatch not in WCS!")
    
87.         )
    
88.         (setq xv (cdr (assoc 210 ed1)))
    
89.         (command "._ucs" "_w")
    
90.         (setq loops1 (cdr (assoc 91 ed1))) ; number of boundary paths (loops)
    
91.         (if (and A2k (= (strcase (cdr (assoc 410 ed1))) "MODEL"))
    
92.           (setq space *ModelSpace*)
    
93.           (setq space *PaperSpace*)
    
94.         )
    
95.         (repeat        loops1
    
96.           (setq ed1 (member (assoc 92 ed1) ed1))
    
97.           (setq bptf (cdr (car ed1)))        ; boundary path type flag
    
98.           (setq ic (cdr (assoc 73 ed1))) ; is closed
    
99.           (setq noe (cdr (assoc 93 ed1))) ; number of edges
    
100.           (setq ed1 (member (assoc 72 ed1) ed1))
     
101.           (setq bul (cdr (car ed1)))        ; bulge
     
102.           (setq plist nil)
     
103.           (setq blist nil)
     
104.           (cond
     
105.             ((> (boole 1 bptf 2) 0)        ; polyline
     
106.              (repeat noe
     
107.                (setq ed1 (member (assoc 10 (cdr ed1)) ed1))
     
108.                (setq plist (append plist (list (cdr (assoc 10 ed1)))))
     
109.                (setq blist (append blist
     
110.                                    (if (> bul 0)
     
111.                                      (list (cdr (assoc 42 ed1)))
     
112.                                      nil
     
113.                                    )
     
114.                            )
     
115.                )
     
116.              )
     
117.              (if A2k
     
118.                (progn (setq polypoints
     
119.                              (apply 'append (mapcar '3dPoint->2dPoint plist))
     
120.                       )
     
121.                       (setq VLADataPts (list->variantArray polypoints))
     
122.                       (setq obj (vla-addLightweightPolyline space VLADataPts))
     
123.                       (setq nr 0)
     
124.                       (repeat (length blist)
     
125.                         (if (/= (nth nr blist) 0)
     
126.                           (vla-setBulge obj nr (nth nr blist))
     
127.                         )
     
128.                         (setq nr (1+ nr))
     
129.                       )
     
130.                       (if (= ic 1)
     
131.                         (vla-put-closed obj T)
     
132.                       )
     
133.                )
     
134.                (progn
     
135.                  (if (= ic 1)
     
136.                    (entmake '((0 . "POLYLINE") (66 . 1) (70 . 1)))
     
137.                    (entmake '((0 . "POLYLINE") (66 . 1)))
     
138.                  )
     
139.                  (setq nr 0)
     
140.                  (repeat (length plist)
     
141.                    (if (= bul 0)
     
142.                      (entmake (list (cons 0 "VERTEX") (cons 10 (nth nr plist))))
     
143.                      (entmake (list (cons 0 "VERTEX")
     
144.                                     (cons 10 (nth nr plist))
     
145.                                     (cons 42 (nth nr blist))
     
146.                               )
     
147.                      )
     
148.                    )
     
149.                    (setq nr (1+ nr))
     
150.                  )
     
151.                  (entmake '((0 . "SEQEND")))
     
152.                )
     
153.              )
     
154.             )
     
155.             (t                                ; not polyline
     
156.              (setq lastent (entlast))
     
157.              (setq lwp T)
     
158.              (repeat noe
     
159.                (setq et (cdr (assoc 72 ed1)))
     
160.                (cond
     
161.                  ((= et 1)                ; line
     
162.                   (setq ed1 (member (assoc 10 (cdr ed1)) ed1))
     
163.                   (if A2k
     
164.                     (vla-AddLine
     
165.                       space
     
166.                       (vlax-3d-point (cdr (assoc 10 ed1)))
     
167.                       (vlax-3d-point (cdr (assoc 11 ed1)))
     
168.                     )
     
169.                     (entmake
     
170.                       (list
     
171.                         (cons 0 "LINE")
     
172.                         (list 10 (cadr (assoc 10 ed1)) (caddr (assoc 10 ed1)) 0)
     
173.                         (list 11 (cadr (assoc 11 ed1)) (caddr (assoc 11 ed1)) 0)
     
174.                                         ;  (cons 210 xv)
     
175.                       )
     
176.                     )
     
177.                   )
     
178.                   (setq ed1 (cddr ed1))
     
179.                  )
     
180.                  ((= et 2)                ; circular arc
     
181.                   (setq ed1 (member (assoc 10 (cdr ed1)) ed1))
     
182.                   (setq ang1 (cdr (assoc 50 ed1)))
     
183.                   (setq ang2 (cdr (assoc 51 ed1)))
     
184.                   (setq cw (cdr (assoc 73 ed1)))
     
185.                   (if (equal ang2 6.28319 0.00001)
     
186.                     (progn
     
187.                       (if A2k
     
188.                         (vla-AddCircle
     
189.                           space
     
190.                           (vlax-3d-point (cdr (assoc 10 ed1)))
     
191.                           (cdr (assoc 40 ed1))
     
192.                         )
     
193.                         (entmake
     
194.                           (list (cons 0 "CIRCLE") (assoc 10 ed1) (assoc 40 ed1))
     
195.                         )
     
196.                       )
     
197.                       (setq lwp nil)
     
198.                     )
     
199.                     (if        A2k
     
200.                       (vla-AddArc
     
201.                         space
     
202.                         (vlax-3d-point (cdr (assoc 10 ed1)))
     
203.                         (cdr (assoc 40 ed1))
     
204.                         (if (= cw 0)
     
205.                           (- 0 ang2)
     
206.                           ang1
     
207.                         )
     
208.                         (if (= cw 0)
     
209.                           (- 0 ang1)
     
210.                           ang2
     
211.                         )
     
212.                       )
     
213.                       (entmake (list (cons 0 "ARC")
     
214.                                      (assoc 10 ed1)
     
215.                                      (assoc 40 ed1)
     
216.                                      (cons 50
     
217.                                            (if (= cw 0)
     
218.                                              (- 0 ang2)
     
219.                                              ang1
     
220.                                            )
     
221.                                      )
     
222.                                      (cons 51
     
223.                                            (if (= cw 0)
     
224.                                              (- 0 ang1)
     
225.                                              ang2
     
226.                                            )
     
227.                                      )
     
228.                                )
     
229.                       )
     
230.                     )
     
231.                   )
     
232.                   (setq ed1 (cddddr ed1))
     
233.                  )
     
234.                  ((= et 3)                ; elliptic arc
     
235.                   (setq ed1 (member (assoc 10 (cdr ed1)) ed1))
     
236.                   (setq ang1 (cdr (assoc 50 ed1)))
     
237.                   (setq ang2 (cdr (assoc 51 ed1)))
     
238.                   (setq cw (cdr (assoc 73 ed1)))
     
239.                   (if A2k
     
240.                     (progn (setq obj (vla-AddEllipse
     
241.                                        space
     
242.                                        (vlax-3d-point (cdr (assoc 10 ed1)))
     
243.                                        (vlax-3d-point (cdr (assoc 11 ed1)))
     
244.                                        (cdr (assoc 40 ed1))
     
245.                                      )
     
246.                            )
     
247.                            (vla-put-startangle
     
248.                              obj
     
249.                              (if (= cw 0)
     
250.                                (- 0 ang2)
     
251.                                ang1
     
252.                              )
     
253.                            )
     
254.                            (vla-put-endangle
     
255.                              obj
     
256.                              (if (= cw 0)
     
257.                                (- 0 ang1)
     
258.                                ang2
     
259.                              )
     
260.                            )
     
261.                     )
     
262.                     (princ "\nElliptic arc not supported!")
     
263.                   )
     
264.                   (setq lwp nil)
     
265.                  )
     
266.                  ((= et 4)                ; spline
     
267.                   (setq ed1 (member (assoc 94 (cdr ed1)) ed1))
     
268.                   (setq knot-list nil)
     
269.                   (setq controlpoint-list nil)
     
270.                   (setq kn (cdr (assoc 95 ed1)))
     
271.                   (setq cn (cdr (assoc 96 ed1)))
     
272.                   (setq pos (vl-position (assoc 40 ed1) ed1))
     
273.                   (repeat kn
     
274.                     (setq
     
275.                       knot-list        (cons (cons 40 (cdr (nth pos ed1))) knot-list)
     
276.                     )
     
277.                     (setq pos (1+ pos))
     
278.                   )
     
279.                   (setq pos (vl-position (assoc 10 ed1) ed1))
     
280.                   (repeat cn
     
281.                     (setq controlpoint-list
     
282.                            (cons (cons 10 (cdr (nth pos ed1)))
     
283.                                  controlpoint-list
     
284.                            )
     
285.                     )
     
286.                     (setq pos (1+ pos))
     
287.                   )
     
288.                   (setq knot-list (reverse knot-list))
     
289.                   (setq controlpoint-list (reverse controlpoint-list))
     
290.                   (entmake (append (list '(0 . "SPLINE"))
     
291.                                    (list (cons 100 "AcDbEntity"))
     
292.                                    (list (cons 100 "AcDbSpline"))
     
293.                                    (list (cons 70
     
294.                                                (+ 1
     
295.                                                   8
     
296.                                                   (* 2 (cdr (assoc 74 ed1)))
     
297.                                                   (* 4 (cdr (assoc 73 ed1)))
     
298.                                                )
     
299.                                          )
     
300.                                    )
     
301.                                    (list (cons 71 (cdr (assoc 94 ed1))))
     
302.                                    (list (cons 72 kn))
     
303.                                    (list (cons 73 cn))
     
304.                                    knot-list
     
305.                                    controlpoint-list
     
306.                            )
     
307.                   )
     
308.                   (setq ed1 (member (assoc 10 ed1) ed1))
     
309.                   (setq lwp nil)
     
310.                  )
     
311.                )                        ; end cond
     
312.              )                                ; end repeat noe
     
313.              (if lwp
     
314.                (progn
     
315.                  (setq en1 (entnext lastent))
     
316.                  (setq ss (ssadd))
     
317.                  (ssadd en1 ss)
     
318.                  (while (setq en2 (entnext en1)) (ssadd en2 ss) (setq en1 en2))
     
319.                  (command "_.pedit" (entlast) "_Y" "_J" ss "" "")
     
320.                )
     
321.              )
     
322.             )                                ; end t
     
323.           )                                ; end cond
     
324.         )                                ; end repeat loops1
     
325.         (setq i (1+ i))
     
326.       )
     
327.     )
     
328.   )
     
329.   (restore)
     
330.   (princ)
     
331. )
     
332. [/font]
     

[font=courier]<br /> ;;; HATCHB.LSP ver 1.6<br /> ;;; Recreates hatch boundary by selecting a hatch<br /> ;;; Boundary is created in current layer/color/linetype in WCS<br /> ;;; By Jimmy Bergmark<br /> ;;; Copyright (C) 1997-2002 JTB World, All Rights Reserved<br /> ;;; Website: [url]www.jtbworld.com[/url] / [url]http://jtbworld.vze.com[/url]<br /> ;;; E-mail: [email]info@jtbworld.com[/email] / [email]jtbworld@hotmail.com[/email]<br /> ;;; 2000-02-12 - First release<br /> ;;; 2000-03-27 - Counterclockwise arc's and ellipse's fixed<br /> ;;;              Objects created joined to lwpolyline if possible<br /> ;;;              Error-handling, undo of command<br /> ;;;              Can handle PLINETYPE = 0,1,2<br /> ;;; 2000-03-30 - Integrating hatchb and hatchb14<br /> ;;;              Selection of many hatches<br /> ;;;              Splines supported if closed.<br /> ;;; 2001-04-02 - Fixed bug with entmake of line with no Z for r14<br /> ;;; 2001-07-31 - Removed an irritating semicolon to enable polylines to be created.<br /> ;;; 2001-10-04 - Changed mail and homepage so it's easy to find when new versions comes up.<br /> ;;; Tested on AutoCAD r14, 2000, 2000i, 2002<br /> ;;; should be working on older versions too.<br /> <br /> (defun c:hatchb        (/            es               blay          ed1             ed2<br />                  loops1            bptf       part          et             noe<br />                  plist            ic               bul          nr             ang1<br />                  ang2            obj               *ModelSpace*             *PaperSpace*<br />                  space            cw               errexit          undox             olderr<br />                  oldcmdecho ss1               lastent          en1             en2<br />                  ss            lwp               list->variantArray    3dPoint->2dPoint<br />                  A2k            ent               i          ss2             knot-list<br />                  controlpoint-list     kn          cn             pos<br />                  xv<br />                 )<br />   (setq A2k (wcmatch (getvar "ACADVER") "15*"))<br />   (if A2k<br />     (defun list->variantArray (ptsList / arraySpace sArray)<br />       (setq arraySpace<br />              (vlax-make-safearray<br />                vlax-vbdouble<br />                (cons 0 (- (length ptsList) 1))<br />              )<br />       )<br />       (setq sArray (vlax-safearray-fill arraySpace ptsList))<br />       (vlax-make-variant sArray)<br />     )<br />   )<br />   (if A2k<br />     (defun 3dPoint->2dPoint (3dpt)<br />       (list (float (car 3dpt)) (float (cadr 3dpt)))<br />     )<br />   )<br />   (defun errexit (s) (princ "\nError:  ") (princ s) (restore))<br />   (defun undox ()<br />     (command "._ucs" "_p")<br />     (command "._undo" "_E")<br />     (setvar "cmdecho" oldcmdecho)<br />     (setq *error* olderr)<br />     (princ)<br />   )<br />   (setq        olderr        *error*<br />         restore        undox<br />         *error*        errexit<br />   )<br />   (setq oldcmdecho (getvar "cmdecho"))<br />   (setvar "cmdecho" 0)<br />   (command "._UNDO" "_BE")<br />   (if A2k<br />     (progn (vl-load-com)<br />            (setq *ModelSpace* (vla-get-ModelSpace<br />                                 (vla-get-ActiveDocument (vlax-get-acad-object))<br />                               )<br />                  *PaperSpace* (vla-get-PaperSpace<br />                                 (vla-get-ActiveDocument (vlax-get-acad-object))<br />                               )<br />            )<br />     )<br />   )                                        ; For testing purpose<br />                                         ; (setq A2k nil)<br />   (if (/= (setq ss2 (ssget '((0 . "HATCH")))) nil)<br />     (progn<br />       (setq i 0)<br />       (while (setq ent (ssname ss2 i))<br />         (setq ed1 (entget ent))<br />         (if (not (equal (assoc 210 ed1) '(210 0.0 0.0 1.0)))<br />           (princ "\nHatch not in WCS!")<br />         )<br />         (setq xv (cdr (assoc 210 ed1)))<br />         (command "._ucs" "_w")<br />         (setq loops1 (cdr (assoc 91 ed1))) ; number of boundary paths (loops)<br />         (if (and A2k (= (strcase (cdr (assoc 410 ed1))) "MODEL"))<br />           (setq space *ModelSpace*)<br />           (setq space *PaperSpace*)<br />         )<br />         (repeat        loops1<br />           (setq ed1 (member (assoc 92 ed1) ed1))<br />           (setq bptf (cdr (car ed1)))        ; boundary path type flag<br />           (setq ic (cdr (assoc 73 ed1))) ; is closed<br />           (setq noe (cdr (assoc 93 ed1))) ; number of edges<br />           (setq ed1 (member (assoc 72 ed1) ed1))<br />           (setq bul (cdr (car ed1)))        ; bulge<br />           (setq plist nil)<br />           (setq blist nil)<br />           (cond<br />             ((> (boole 1 bptf 2) 0)        ; polyline<br />              (repeat noe<br />                (setq ed1 (member (assoc 10 (cdr ed1)) ed1))<br />                (setq plist (append plist (list (cdr (assoc 10 ed1)))))<br />                (setq blist (append blist<br />                                    (if (> bul 0)<br />                                      (list (cdr (assoc 42 ed1)))<br />                                      nil<br />                                    )<br />                            )<br />                )<br />              )<br />              (if A2k<br />                (progn (setq polypoints<br />                              (apply 'append (mapcar '3dPoint->2dPoint plist))<br />                       )<br />                       (setq VLADataPts (list->variantArray polypoints))<br />                       (setq obj (vla-addLightweightPolyline space VLADataPts))<br />                       (setq nr 0)<br />                       (repeat (length blist)<br />                         (if (/= (nth nr blist) 0)<br />                           (vla-setBulge obj nr (nth nr blist))<br />                         )<br />                         (setq nr (1+ nr))<br />                       )<br />                       (if (= ic 1)<br />                         (vla-put-closed obj T)<br />                       )<br />                )<br />                (progn<br />                  (if (= ic 1)<br />                    (entmake '((0 . "POLYLINE") (66 . 1) (70 . 1)))<br />                    (entmake '((0 . "POLYLINE") (66 . 1)))<br />                  )<br />                  (setq nr 0)<br />                  (repeat (length plist)<br />                    (if (= bul 0)<br />                      (entmake (list (cons 0 "VERTEX") (cons 10 (nth nr plist))))<br />                      (entmake (list (cons 0 "VERTEX")<br />                                     (cons 10 (nth nr plist))<br />                                     (cons 42 (nth nr blist))<br />                               )<br />                      )<br />                    )<br />                    (setq nr (1+ nr))<br />                  )<br />                  (entmake '((0 . "SEQEND")))<br />                )<br />              )<br />             )<br />             (t                                ; not polyline<br />              (setq lastent (entlast))<br />              (setq lwp T)<br />              (repeat noe<br />                (setq et (cdr (assoc 72 ed1)))<br />                (cond<br />                  ((= et 1)                ; line<br />                   (setq ed1 (member (assoc 10 (cdr ed1)) ed1))<br />                   (if A2k<br />                     (vla-AddLine<br />                       space<br />                       (vlax-3d-point (cdr (assoc 10 ed1)))<br />                       (vlax-3d-point (cdr (assoc 11 ed1)))<br />                     )<br />                     (entmake<br />                       (list<br />                         (cons 0 "LINE")<br />                         (list 10 (cadr (assoc 10 ed1)) (caddr (assoc 10 ed1)) 0)<br />                         (list 11 (cadr (assoc 11 ed1)) (caddr (assoc 11 ed1)) 0)<br />                                         ;  (cons 210 xv)<br />                       )<br />                     )<br />                   )<br />                   (setq ed1 (cddr ed1))<br />                  )<br />                  ((= et 2)                ; circular arc<br />                   (setq ed1 (member (assoc 10 (cdr ed1)) ed1))<br />                   (setq ang1 (cdr (assoc 50 ed1)))<br />                   (setq ang2 (cdr (assoc 51 ed1)))<br />                   (setq cw (cdr (assoc 73 ed1)))<br />                   (if (equal ang2 6.28319 0.00001)<br />                     (progn<br />                       (if A2k<br />                         (vla-AddCircle<br />                           space<br />                           (vlax-3d-point (cdr (assoc 10 ed1)))<br />                           (cdr (assoc 40 ed1))<br />                         )<br />                         (entmake<br />                           (list (cons 0 "CIRCLE") (assoc 10 ed1) (assoc 40 ed1))<br />                         )<br />                       )<br />                       (setq lwp nil)<br />                     )<br />                     (if        A2k<br />                       (vla-AddArc<br />                         space<br />                         (vlax-3d-point (cdr (assoc 10 ed1)))<br />                         (cdr (assoc 40 ed1))<br />                         (if (= cw 0)<br />                           (- 0 ang2)<br />                           ang1<br />                         )<br />                         (if (= cw 0)<br />                           (- 0 ang1)<br />                           ang2<br />                         )<br />                       )<br />                       (entmake (list (cons 0 "ARC")<br />                                      (assoc 10 ed1)<br />                                      (assoc 40 ed1)<br />                                      (cons 50<br />                                            (if (= cw 0)<br />                                              (- 0 ang2)<br />                                              ang1<br />                                            )<br />                                      )<br />                                      (cons 51<br />                                            (if (= cw 0)<br />                                              (- 0 ang1)<br />                                              ang2<br />                                            )<br />                                      )<br />                                )<br />                       )<br />                     )<br />                   )<br />                   (setq ed1 (cddddr ed1))<br />                  )<br />                  ((= et 3)                ; elliptic arc<br />                   (setq ed1 (member (assoc 10 (cdr ed1)) ed1))<br />                   (setq ang1 (cdr (assoc 50 ed1)))<br />                   (setq ang2 (cdr (assoc 51 ed1)))<br />                   (setq cw (cdr (assoc 73 ed1)))<br />                   (if A2k<br />                     (progn (setq obj (vla-AddEllipse<br />                                        space<br />                                        (vlax-3d-point (cdr (assoc 10 ed1)))<br />                                        (vlax-3d-point (cdr (assoc 11 ed1)))<br />                                        (cdr (assoc 40 ed1))<br />                                      )<br />                            )<br />                            (vla-put-startangle<br />                              obj<br />                              (if (= cw 0)<br />                                (- 0 ang2)<br />                                ang1<br />                              )<br />                            )<br />                            (vla-put-endangle<br />                              obj<br />                              (if (= cw 0)<br />                                (- 0 ang1)<br />                                ang2<br />                              )<br />                            )<br />                     )<br />                     (princ "\nElliptic arc not supported!")<br />                   )<br />                   (setq lwp nil)<br />                  )<br />                  ((= et 4)                ; spline<br />                   (setq ed1 (member (assoc 94 (cdr ed1)) ed1))<br />                   (setq knot-list nil)<br />                   (setq controlpoint-list nil)<br />                   (setq kn (cdr (assoc 95 ed1)))<br />                   (setq cn (cdr (assoc 96 ed1)))<br />                   (setq pos (vl-position (assoc 40 ed1) ed1))<br />                   (repeat kn<br />                     (setq<br />                       knot-list        (cons (cons 40 (cdr (nth pos ed1))) knot-list)<br />                     )<br />                     (setq pos (1+ pos))<br />                   )<br />                   (setq pos (vl-position (assoc 10 ed1) ed1))<br />                   (repeat cn<br />                     (setq controlpoint-list<br />                            (cons (cons 10 (cdr (nth pos ed1)))<br />                                  controlpoint-list<br />                            )<br />                     )<br />                     (setq pos (1+ pos))<br />                   )<br />                   (setq knot-list (reverse knot-list))<br />                   (setq controlpoint-list (reverse controlpoint-list))<br />                   (entmake (append (list '(0 . "SPLINE"))<br />                                    (list (cons 100 "AcDbEntity"))<br />                                    (list (cons 100 "AcDbSpline"))<br />                                    (list (cons 70<br />                                                (+ 1<br />                                                   8<br />                                                   (* 2 (cdr (assoc 74 ed1)))<br />                                                   (* 4 (cdr (assoc 73 ed1)))<br />                                                )<br />                                          )<br />                                    )<br />                                    (list (cons 71 (cdr (assoc 94 ed1))))<br />                                    (list (cons 72 kn))<br />                                    (list (cons 73 cn))<br />                                    knot-list<br />                                    controlpoint-list<br />                            )<br />                   )<br />                   (setq ed1 (member (assoc 10 ed1) ed1))<br />                   (setq lwp nil)<br />                  )<br />                )                        ; end cond<br />              )                                ; end repeat noe<br />              (if lwp<br />                (progn<br />                  (setq en1 (entnext lastent))<br />                  (setq ss (ssadd))<br />                  (ssadd en1 ss)<br />                  (while (setq en2 (entnext en1)) (ssadd en2 ss) (setq en1 en2))<br />                  (command "_.pedit" (entlast) "_Y" "_J" ss "" "")<br />                )<br />              )<br />             )                                ; end t<br />           )                                ; end cond<br />         )                                ; end repeat loops1<br />         (setq i (1+ i))<br />       )<br />     )<br />   )<br />   (restore)<br />   (princ)<br /> )<br /> [/font]<br />

cgl

非常实用的一个LISP函数，解决了我的一个大问题，感谢的同时，建议晓动给秋枫斑竹加分，虽然积分对秋枫已经没什么意义，但能体现对论坛的贡献！

zhynt

哎呀，看似简单的一个问题实现起来却不简单哟。谢谢秋哥！
从哪儿找到的？象是老外便的吧。

秋枫

http://jtbworld.vze.com/

程序注释中标明了。

maxbug

好程序,谢谢!