[转贴]：vp-outline

eachy

2. 
   
3. ;;; vp-outline.lsp
   
4. ;;;
   
5. ;;; Creates a polyline in modelspace that
   
6. ;;; has the outline of the selected viewport.
   
7. ;;; Supports clipped viewports.
   
8. ;;; If vp-outline is called when in mspace it detects
   
9. ;;; the active viewport.
   
10. ;;;
    
11. ;;; c:vp-outline
    
12. ;;;
    
13. ;;; By Jimmy Bergmark
    
14. ;;; Copyright (C) 1997-2005 JTB World, All Rights Reserved
    
15. ;;; Website: [url]www.jtbworld.com[/url]
    
16. ;;; E-mail: [email]info@jtbworld.com[/email]
    
17. ;;;
    
18. ;;; 2000-04-10
    
19. ;;; 2003-11-19 Added support for drawing the outline in other ucs/view than world/current
    
20. ;;;
    
21. ;;; Tested on AutoCAD 2000, 2000i, 2002, 2004
    
22. 
    
23. 
    
24. (defun dxf (n ed) (cdr (assoc n ed)))
    
25. 
    
26. (defun ax:List->VariantArray (lst)
    
27.   (vlax-Make-Variant
    
28.     (vlax-SafeArray-Fill
    
29.       (vlax-Make-SafeArray
    
30.         vlax-vbDouble
    
31.         (cons 0 (- (length lst) 1))
    
32.       )
    
33.       lst
    
34.     )
    
35.   )
    
36. )
    
37. 
    
38. (defun c:vp-outline (/ ad ss ent pl plist xy n vpbl vpur msbl msur ven vpno ok)
    
39.   (setq ad (vla-get-activedocument (vlax-get-acad-object)))
    
40.   (if (= (getvar "tilemode") 0)
    
41.     (progn
    
42.       (if (= (getvar "cvport") 1)
    
43. 
    
44.         (progn
    
45.           (if (setq ss (ssget ":E:S" '((0 . "VIEWPORT"))))
    
46.             (progn
    
47.               (setq ent (ssname ss 0))
    
48.               (setq vpno (dxf 69 (entget ent)))
    
49.               (vla-Display (vlax-ename->vla-object ent) :vlax-true)
    
50.               (vla-put-mspace ad :vlax-true) ; equal (command "._mspace")
    
51.               ; this to ensure trans later is working on correct viewport
    
52.               (setvar "cvport" vpno)
    
53.               (vla-put-mspace ad :vlax-false) ; equal (command "._pspace")
    
54.               (setq ok T)
    
55.             )
    
56.           )
    
57.         )
    
58.         (setq ent (vlax-vla-object->ename (vla-get-activepviewport ad))
    
59.               ok  T
    
60.         )
    
61.       )
    
62.       (if ok
    
63.         (progn
    
64.           (setq ven (vlax-ename->vla-object ent))
    
65.           (if (/= 1 (logand 1 (dxf 90 (entget ent)))) ; detect perspective
    
66.             (if (= (vla-get-clipped ven) :vlax-false)
    
67.                (progn                 ; not clipped
    
68.                  (vla-getboundingbox ven 'vpbl 'vpur)
    
69.                  (setq msbl  (trans (vlax-safearray->list vpbl) 3 2)
    
70.                        msbl  (trans msbl 2 1)
    
71.                        msbl  (trans msbl 1 0)
    
72.                        msur  (trans (vlax-safearray->list vpur) 3 2)
    
73.                        msur  (trans msur 2 1)
    
74.                        msur  (trans msur 1 0)
    
75.                        plist (list (car msbl) (cadr msbl)
    
76.                                    (car msur) (cadr msbl)
    
77.                                    (car msur) (cadr msur)
    
78.                                    (car msbl) (cadr msur)
    
79.                              )
    
80.                  )
    
81.                )
    
82.                (progn                 ; clipped
    
83.                  (setq pl    (entget (dxf 340 (entget ent)))
    
84.                        plist (vla-get-coordinates
    
85.                                (vlax-ename->vla-object (dxf -1 pl))
    
86.                              )
    
87.                        plist (vlax-safearray->list (vlax-variant-value plist))
    
88.                        n     0
    
89.                        pl    nil
    
90.                  )
    
91.                  (repeat (/ (length plist) 2)
    
92.                    (setq xy (trans (list (nth n plist) (nth (1+ n) plist)) 3 2)
    
93.                          xy  (trans xy 2 1)
    
94.                          xy  (trans xy 1 0)
    
95.                          pl (cons (car xy) pl)
    
96.                          pl (cons (cadr xy) pl)
    
97.                          n  (+ n 2)
    
98.                    )
    
99.                  )
    
100.                  (setq plist (reverse pl))
     
101.                )
     
102.             )
     
103.           )
     
104.           (setq plist (ax:List->VariantArray plist))
     
105.           (vla-Put-Closed
     
106.             (vla-AddLightWeightPolyline
     
107.               (vla-get-ModelSpace ad)
     
108.               plist
     
109.             )
     
110.             :vlax-True
     
111.           )
     
112.         )
     
113.       )
     
114.     )
     
115.   )
     
116.   (princ)
     
117. )

<br /> ;;; vp-outline.lsp<br /> ;;;<br /> ;;; Creates a polyline in modelspace that<br /> ;;; has the outline of the selected viewport.<br /> ;;; Supports clipped viewports.<br /> ;;; If vp-outline is called when in mspace it detects<br /> ;;; the active viewport.<br /> ;;;<br /> ;;; c:vp-outline<br /> ;;;<br /> ;;; By Jimmy Bergmark<br /> ;;; Copyright (C) 1997-2005 JTB World, All Rights Reserved<br /> ;;; Website: [url]www.jtbworld.com[/url]<br /> ;;; E-mail: [email]info@jtbworld.com[/email]<br /> ;;;<br /> ;;; 2000-04-10<br /> ;;; 2003-11-19 Added support for drawing the outline in other ucs/view than world/current<br /> ;;;<br /> ;;; Tested on AutoCAD 2000, 2000i, 2002, 2004<br /> <br /> <br /> (defun dxf (n ed) (cdr (assoc n ed)))<br /> <br /> (defun ax:List->VariantArray (lst)<br />   (vlax-Make-Variant<br />     (vlax-SafeArray-Fill<br />       (vlax-Make-SafeArray<br />         vlax-vbDouble<br />         (cons 0 (- (length lst) 1))<br />       )<br />       lst<br />     )<br />   )<br /> )<br /> <br /> (defun c:vp-outline (/ ad ss ent pl plist xy n vpbl vpur msbl msur ven vpno ok)<br />   (setq ad (vla-get-activedocument (vlax-get-acad-object)))<br />   (if (= (getvar "tilemode") 0)<br />     (progn<br />       (if (= (getvar "cvport") 1)<br /> <br />         (progn<br />           (if (setq ss (ssget ":E:S" '((0 . "VIEWPORT"))))<br />             (progn<br />               (setq ent (ssname ss 0))<br />               (setq vpno (dxf 69 (entget ent)))<br />               (vla-Display (vlax-ename->vla-object ent) :vlax-true)<br />               (vla-put-mspace ad :vlax-true) ; equal (command "._mspace")<br />               ; this to ensure trans later is working on correct viewport<br />               (setvar "cvport" vpno)<br />               (vla-put-mspace ad :vlax-false) ; equal (command "._pspace")<br />               (setq ok T)<br />             )<br />           )<br />         )<br />         (setq ent (vlax-vla-object->ename (vla-get-activepviewport ad))<br />               ok  T<br />         )<br />       )<br />       (if ok<br />         (progn<br />           (setq ven (vlax-ename->vla-object ent))<br />           (if (/= 1 (logand 1 (dxf 90 (entget ent)))) ; detect perspective<br />             (if (= (vla-get-clipped ven) :vlax-false)<br />                (progn                 ; not clipped<br />                  (vla-getboundingbox ven 'vpbl 'vpur)<br />                  (setq msbl  (trans (vlax-safearray->list vpbl) 3 2)<br />                        msbl  (trans msbl 2 1)<br />                        msbl  (trans msbl 1 0)<br />                        msur  (trans (vlax-safearray->list vpur) 3 2)<br />                        msur  (trans msur 2 1)<br />                        msur  (trans msur 1 0)<br />                        plist (list (car msbl) (cadr msbl)<br />                                    (car msur) (cadr msbl)<br />                                    (car msur) (cadr msur)<br />                                    (car msbl) (cadr msur)<br />                              )<br />                  )<br />                )<br />                (progn                 ; clipped<br />                  (setq pl    (entget (dxf 340 (entget ent)))<br />                        plist (vla-get-coordinates<br />                                (vlax-ename->vla-object (dxf -1 pl))<br />                              )<br />                        plist (vlax-safearray->list (vlax-variant-value plist))<br />                        n     0<br />                        pl    nil<br />                  )<br />                  (repeat (/ (length plist) 2)<br />                    (setq xy (trans (list (nth n plist) (nth (1+ n) plist)) 3 2)<br />                          xy  (trans xy 2 1)<br />                          xy  (trans xy 1 0)<br />                          pl (cons (car xy) pl)<br />                          pl (cons (cadr xy) pl)<br />                          n  (+ n 2)<br />                    )<br />                  )<br />                  (setq plist (reverse pl))<br />                )<br />             )<br />           )<br />           (setq plist (ax:List->VariantArray plist))<br />           (vla-Put-Closed<br />             (vla-AddLightWeightPolyline<br />               (vla-get-ModelSpace ad)<br />               plist<br />             )<br />             :vlax-True<br />           )<br />         )<br />       )<br />     )<br />   )<br />   (princ)<br /> )