[编程交流] 填充图案填充LISP

;;-------------------Solid Hatch}-----------------------;;
;;                                                      ;;
;;              Creates a solid hatch                   ;;
;;      with respect to the color of the objects        ;;
;;------------------------------------------------------;;
(defun c:Sldhtch (/ *error* v l ss doc)
 (defun C:hatchcol2 ( / obj hatcol pt)
(vl-load-com)
(princ "\nPlease pick object for color")
(setq obj (car (entsel)))
(setq hatcol (vlax-get-property (vlax-Ename->Vla-Object obj) 'color))
(setq pt (getpoint "\nPlease pick inside objects"))
(setvar "HPNAME" "Solid") ;set hatch pattern
(command "-Hatch" pt "" "CO" hatcol "" "")
)
       
 (defun *error* (x)
   (if v
     (mapcar 'setvar '(HPNAME CMDECHO) v)
   )
   (if (wcmatch (strcase x) "*BREAK*,*CANCEL*,*EXIT*")
     (princ (strcat "\n** Error: " x " **"))
   )
 )
 (setq l (entlast)
       v (mapcar 'getvar '(HPNAME CMDECHO))
 )
 (if (setq ss (ssget "_:L" '((0 . "SPLINE"))))
   (progn (mapcar 'setvar '(HPNAME CMDECHO) '("SOLID" 0))
          (setq l (entlast))
          (vla-startUndomark (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
          ((lambda (i / sn c o)
             (while (setq sn (ssname ss (setq i (1+ i))))
               (command "_.-hatch" "S" sn "" "")
               (if (not (eq l (setq o (entlast))))
                 (if (setq c (assoc 62 (entget sn)))
                   (entmod (append (entget o) (list (cons 62 (cdr c)))))
                   (entmod (append (entget o) '((62 . 256))))
                 )
               )
               (setq l o)
             )
           )
            -1
          )
          (vla-Endundomark doc)
   )
 )
 (*error* nil)
)(vl-load-com)