[编程交流] 将颜色指定给2d

(defun c:overlap (/ *error* RotateByMatrix AddLwPoly BBox->List GroupByNum GetTextIns Point
                   ALLOBJS DOC FILTLST ILST LAYER LL NOBJ POLY PT R SPC SS UFLAG UR)
 
 ;; Lee Mac  ~  15.03.10
 (vl-load-com)
 (defun *error* (msg)
   (and uFlag (vla-EndUndomark doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))    
 
 (setq layer "OverLapCheck")
 (setq FiltLst '((-4 . "<NOT") (0 . "VIEWPORT") (-4 . "NOT>")))
 (defun RotateByMatrix (obj pt ang / RotationMatrix Vector)
   ;; Rotation by Matrix  ~  Lee Mac 
   (setq RotationMatrix (list (list (cos ang) (- (sin ang))  0.0)
                              (list (sin ang)    (cos ang)   0.0)
                              (list    0.0           0.0     1.0)))
   (setq Vector (mapcar (function -) pt
                        (mapcar
                          (function
                            (lambda (row) (apply (function +)
                                                 (mapcar (function *) row pt))))
                          RotationMatrix)))
   (vla-transformby obj
     (vlax-tmatrix
       (append
         (mapcar
           (function
             (lambda (r x) (append r (list x))))
           RotationMatrix Vector)
         '((0.0 0.0 0.0 1.0))))))
 
 (defun AddLWPoly (blk lst)
   (vla-AddLightWeightPolyline blk
     (vlax-make-variant
       (vlax-safearray-fill
         (vlax-make-safearray vlax-vbDouble
           (cons 0 (1- (* 2 (length lst)))))
         (apply (function append) lst)))))
 
 (defun BBox->List (bbox)
   (  (lambda (bbox)
        (mapcar
          (function
            (lambda (funcs)
              (mapcar
                (function
                  (lambda (func)
                    (apply func bbox)))
                
                funcs)))
          
          '((caar  cadar)  (caadr cadar)
            (caadr cadadr) (caar  cadadr))))
     
     (list bbox)))
 
 (defun GroupByNum (lst num / rtn)
   (setq rtn nil)
   
   (if lst
     (cons (reverse
             (repeat num
               (progn
                 (setq rtn (cons (car lst) rtn)
                       lst (cdr lst))
                 rtn)))
           
           (GroupByNum lst num))))
 
 (defun GetTextIns (object)
   (vlax-get object
     (if (eq "AcDbText" (vla-get-ObjectName object))
       (if (eq acAlignmentLeft (vla-get-Alignment object))
         'InsertionPoint 'TextAlignmentPoint)
       'InsertionPoint)))
 
 (defun Point (pt)
   (entmakex (list (cons 0 "POINT")
                   (cons 8 layer)
                   (cons 10 pt)                    
                   (cons 62 2))))
 
 (defun SS->VLA (ss / i e lst)
   (setq i -1)
   (if ss
     (while (setq e (ssname ss (setq i (1+ i))))
       (setq lst (cons (vlax-ename->vla-object e) lst))))
   
   lst)  
 
 (setq doc (vla-get-ActiveDocument
             (vlax-get-acad-object))
       spc (if (or (eq acModelSpace (vla-get-ActiveSpace doc))
                   (eq :vlax-true   (vla-get-MSpace doc)))
             (vla-get-ModelSpace doc)
             (vla-get-PaperSpace doc)))  
 (or (tblsearch "LAYER" layer)
     (vla-add (vla-get-layers doc) layer))
 (setq AllObjs (ss->VLA (ssget "_X" FiltLst)))
 
 (if (ssget '((0 . "TEXT,MTEXT,INSERT")))
   (progn
     (setq uFlag (not (vla-StartUndoMark doc)))
     
     (vlax-for obj (setq ss (vla-get-ActiveSelectionSet doc))
       (if (not (zerop (setq r (+ (vla-get-Rotation obj)   
                                  (setq ucsx
                                    (if (eq (vla-get-Objectname obj) "AcDbMText")
                                      (angle '(0 0 0) (getvar 'UCSXDIR)) 0.))))))
         (progn
           (vla-put-rotation (setq nobj (vla-copy obj)) (- 0.0 ucsx))
           (vla-getBoundingBox nobj 'll 'ur)
           (RotateByMatrix              
             (setq Poly
               (AddLWPoly spc
                 (BBox->List
                   (mapcar (function vlax-safearray->list)
                           (list ll ur)))))
             (GetTextIns obj) r)
           
           (vla-put-layer Poly layer)
           (vla-put-Closed Poly :vlax-true)
           (vla-delete nobj))
         (progn
           (vla-getBoundingBox obj 'll 'ur)
           (vla-put-layer
             (setq Poly
               (AddLWPoly spc
                 (BBox->List
                   (mapcar (function vlax-safearray->list)
                           (list ll ur)))))
             layer)
           
           (vla-put-Closed Poly :vlax-true)))
       (if (setq iLst
                  (apply (function append)
                    (vl-remove-if (function null)
                      (mapcar
                        (function
                          (lambda (object)
                            (GroupByNum
                              (vlax-invoke Poly
                                'IntersectWith object acExtendNone) 3)))
                        
                        (vl-remove obj AllObjs)))))
         
         (progn              
           (vla-put-color Poly acRed)
           (mapcar (function Point) iLst))
         (vla-put-color Poly acGreen)))
     (vla-delete ss)
     (setq uFlag (vla-EndUndoMark doc))))
 (princ))