[编程交流] 如何突出封闭区域

[b][color=BLACK]([/color][/b]defun c:sel-hl [b][color=FUCHSIA]([/color][/b]/ pt1 pt2 pl wl tl gl i ss en[b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]initget 1[b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]setq pt1 [b][color=NAVY]([/color][/b]getpoint [color=#2f4f4f]"\nStart Point:   "[/color][b][color=NAVY])[/color][/b][b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]setq pl [b][color=NAVY]([/color][/b]list pt1[b][color=NAVY])[/color][/b][b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]while [b][color=NAVY]([/color][/b]setq pt2 [b][color=MAROON]([/color][/b]getpoint pt1 [color=#2f4f4f]"\nNext Point:   "[/color][b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
        [b][color=NAVY]([/color][/b]setq pl [b][color=MAROON]([/color][/b]cons pt2 pl[b][color=MAROON])[/color][/b]
             pt1 pt2
              wl [b][color=MAROON]([/color][/b]cons [b][color=GREEN]([/color][/b]last pl[b][color=GREEN])[/color][/b] pl[b][color=MAROON])[/color][/b]
              tl wl
              gl '[b][color=MAROON]([/color][/b][b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
        [b][color=NAVY]([/color][/b]repeat [b][color=MAROON]([/color][/b]length pl[b][color=MAROON])[/color][/b]
            [b][color=MAROON]([/color][/b]setq gl [b][color=GREEN]([/color][/b]append gl [b][color=BLUE]([/color][/b]list 2 [b][color=RED]([/color][/b]car tl[b][color=RED])[/color][/b] [b][color=RED]([/color][/b]cadr tl[b][color=RED])[/color][/b][b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b]
                  tl [b][color=GREEN]([/color][/b]cdr tl[b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
        [b][color=NAVY]([/color][/b]redraw[b][color=NAVY])[/color][/b]
        [b][color=NAVY]([/color][/b]apply 'grvecs [b][color=MAROON]([/color][/b]list gl[b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
        [b][color=NAVY]([/color][/b]and [b][color=MAROON]([/color][/b]setq i -1 ss [b][color=GREEN]([/color][/b]ssget [color=#2f4f4f]"_WP"[/color] wl[b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b]
             [b][color=MAROON]([/color][/b]while [b][color=GREEN]([/color][/b]setq en [b][color=BLUE]([/color][/b]ssname ss [b][color=RED]([/color][/b]setq i [b][color=PURPLE]([/color][/b]1+ i[b][color=PURPLE])[/color][/b][b][color=RED])[/color][/b][b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b]
                    [b][color=GREEN]([/color][/b]redraw en 3[b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b][b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]prin1[b][color=FUCHSIA])[/color][/b][b][color=BLACK])[/color][/b]

;;------------------=={ Shaded SelectionSet  }==--------------;;
;;                                                            ;;
;;  Provides a UCS oriented window/crossing selection set     ;;
;;  interface, with shading visual effect.                    ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  str    - prompt string                                    ;;
;;  p1     - base point for window (UCS)                      ;;
;;  filter - optional selection set filter                    ;;
;;------------------------------------------------------------;;
;;  Returns:  SelectionSet of selected objects, else nil      ;;
;;------------------------------------------------------------;;
(defun LM:GrSelectionSetShaded ( str p1 filter / gr p1 pt1 pt2 vsr hgt wid s1 s2 c1 c2 pi/2 lst )
 ;; © Lee Mac 2010
 (princ str)
 (while (and (= 5 (car (setq gr (grread t 13 1)))) (listp (setq p3 (cadr gr))))
   (redraw)
   (setq vsr  (/ (getvar 'VIEWSIZE) (cadr (getvar 'SCREENSIZE)))
         p2   (list (car p3) (cadr p1) (caddr p3))
         p4   (list (car p1) (cadr p3) (caddr p3))
         hgt  (- (cadr p3) (cadr p1))
         wid  (- (car  p3) (car  p1))          
         s1   (if (minusp wid)  -1.  1.) s2 (if (minusp hgt)  -1.  1.)
         c1   (if (minusp wid) -256 256) c2 (if (minusp wid)  106 156) pi/2 (/ pi 2.) i 0
         hgt  (- hgt (* vsr 2. s2))
   )
   (grvecs (setq lst (list c1 p1 p2 p1 p4 p2 p3 p4 p3)))
   (repeat (1- (fix (/ (abs wid) vsr)))
     (grdraw (setq p5 (polar (polar p1 0. (* s1 (setq i (1+ i)) vsr)) pi/2 (* s2 vsr))) (polar p5 pi/2 hgt) c2)
   )  
 )
 (redraw)
 (ssget (if (minusp (car lst)) "_C" "_W") p1 p3 filter)
)
;; Test Function
(defun c:test ( / p )
 (if (setq p (getpoint "\nClick!: "))
   (sssetfirst nil (LM:GrSelectionSetShaded "\nCorner..." p nil))
 )
 (princ)
)

(defun c:Test (/)
 (sssetfirst nil (_GrSelectionSetShaded (getpoint "\nSpecify first corner: ") '((0 . "LINE"))))
 (princ)
)
(defun _GrSelectionSetShaded (pt flt / *error* _solid foo space sort gr solid opt ss)
 ;; Alan J. Thomspon, 10.18.10
 (defun *error* (m) (redraw) (and solid (setq solid (vla-delete solid))))
 (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
 (setq space (if (or (eq acmodelspace (vla-get-activespace *AcadDoc*))
                     (eq :vlax-true (vla-get-mspace *AcadDoc*))
                 )
               (vla-get-modelspace *AcadDoc*)
               (vla-get-paperspace *AcadDoc*)
             )
 )
 (setq sort (vla-AddObject (vla-GetExtensionDictionary space) "ACAD_SORTENTS" "AcDbSortentsTable"))
 (defun _solid (a b c d color)
   (and solid (setq solid (vla-delete solid)))
   (vl-catch-all-apply
     (function
       (lambda (/)
         (vlax-invoke
           sort
           'MoveToBottom
           (list (setq solid (vlax-ename->vla-object
                               (entmakex (list '(0 . "SOLID")
                                               '(100 . "AcDbTrace")
                                               (cons 62 color)
                                               (cons 10 a)
                                               (cons 11 b)
                                               (cons 12 d)
                                               (cons 13 c)
                                         )
                               )
                             )
                 )
           )
         )
       )
     )
   )
 )
 (defun foo (p1 p2)
   (redraw)
   (if (apply 'and (mapcar 'vl-consp (list p1 p2)))
     ((lambda (l d)
        (apply '_solid
               (reverse (cons (setq opt (if (zerop d)
                                          (getvar 'windowareacolor)
                                          (getvar 'crossingareacolor)
                                        )
                              )
                              (cdr (reverse l))
                        )
               )
        )
        (mapcar '(lambda (a b) (and a b (grdraw a b 7 d))) l (append (cdr l) (list (last l))))
      )
       (list p1 (list (car p2) (cadr p1)) p2 (list (car p1) (cadr p2)) p1)
       (cond ((> (car p1) (car p2)) 1)
             (0)
       )
     )
   )
 )
 (if (vl-consp pt)
   (progn (princ "\rSpecify opposite corner: ")
          (while (eq 5 (car (setq gr (grread T 15 1)))) (foo pt (cadr gr)))
          (redraw)
          (cond ((eq 3 (car gr))
                 (setq ss (ssget (if (eq opt (getvar 'windowareacolor))
                                   "_W"
                                   "_C"
                                 )
                                 pt
                                 (cadr gr)
                                 flt
                          )
                 )
                )
          )
   )
 )
 (*error* nil)
 ss
)