[编程交流] 按层或图案填充区域

(defun c:hareas        (/ _writefile a b key out s)
 (defun _writefile (filename lst / file)
   (cond ((and (eq 'str (type filename)) (setq file (open filename "w")))
   (foreach x lst (write-line x file))
   (close file)
   filename
  )
   )
 )
 (initget 0 "Pattern Layer")
 (if (and (or (setq key (getkword "\nPattern or LayerName [<Pattern>]: ")) (setq key "Pattern"))
   (setq s (ssget '((0 . "hatch"))))
     )
   (progn (setq s
          (mapcar
            '(lambda (x)
               (cons (if (= "Pattern" key)
                       (vla-get-patternname x)
                       (vla-get-layer x)
                     )
                     (if (vl-catch-all-error-p (setq a (vl-catch-all-apply 'vla-get-area (list x))))
                       0.0
                       a
                     )
               )
             )
            (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))))
          )
   )
   (foreach h s
     (if (setq b (assoc (car h) out))
       (setq out (subst (cons (car b) (+ (cdr b) (cdr h))) b out))
       (setq out (cons h out))
     )
   )
   (print (_writefile
            (strcat (getvar 'dwgprefix)
                    (vl-filename-base (getvar 'dwgname))
                    "_Hatch_"
                    key
                    "_Areas.csv"
            )
            (mapcar '(lambda (x) (strcat (car x) "," (vl-princ-to-string (cdr x)))) out)
          )
   )
   (if (setq b (vl-remove-if-not '(lambda (x) (= 0 (cdr x))) out))
     (alert (strcat (itoa (length b)) " hatches have no area property!"))
   )
   )
 )
 (princ)
)
(vl-load-com)

(setq s (ssget "_X" '((0 . "hatch"))))

(setq s (ssget '((0 . "hatch"))))

           (if (setq b (vl-remove-if-not '(lambda (x) (= 0 (cdr x))) out))
     (alert (strcat (itoa (length b)) " hatches have no area property!"))
   )