[编程交流] 连接图案填充

;-----------------------------------------------
;; ø Remove_nth ø  (Lee Mac)          ;;
;; ~ Removes the nth item in a list.  ;;
(defun Remove_nth (i lst / j)
 (setq j -1)
 (vl-remove-if
   (function
     (lambda (x)
       (eq i (setq j (1+ j))))) lst))
;-----------------------------------------------
;; massoc (Jaysen Long)               ;;
;; Extracts info from list by key     ;;
(defun massoc (key alist / x nlist)
(foreach x alist
  (if
    (eq key (car x))
    (setq nlist (cons x nlist))
  )
)
(reverse nlist)
);defun
;-----------------------------------------------
(defun c:MH ( / hentinfo ss i n entinfo ptlist pickpntlst entlist MergedHatchList)
(while (/= (cdr (assoc 0 hentinfo)) "HATCH")
 (setq hentinfo (car (entsel "\nSelect Hatch Pattern to use:")))
 (If hentinfo (setq hentinfo (entget hentinfo)) (princ "\nMissed. Try again.")))
(while (not ss) (princ "Select hatch entities to merge:")(setq ss (ssget '((0 . "HATCH")))))
(setq MergedHatchList
(list (cons 0 "HATCH")                              
     (cons 100 "AcDbEntity")
     (assoc 8 hentinfo)
     (cons 100 "AcDbHatch")
     (assoc 10 hentinfo)
     (assoc 210 hentinfo)
     (assoc 2 hentinfo)
     (assoc 70 hentinfo)
     (assoc 71 hentinfo)
     (cons 91 (sslength ss))
) i -1)
(repeat (sslength ss)
(setq n -1 newlist nil)
(setq entinfo (entget (ssname ss (setq i (1+ i)))))
(setq ptlist (cdr (massoc 10 entinfo)))
(setq pickpntlst (append pickpntlst (list (last ptlist))))
(repeat (cdr (assoc 93 entinfo))(setq newlist (append newlist (list (nth (setq n (1+ n)) ptlist)))))
(setq entlist (append (append (mapcar '(lambda (x) (assoc x entinfo)) '(92 72 73 93)) newlist)(list (assoc 97 entinfo))))
(setq MergedHatchList (append MergedHatchlist entlist))
(entdel (ssname ss i))
)
(setq MergedHatchList
(append MergedHatchList
  (append
    (mapcar '(lambda (x) (assoc x hentinfo)) '(75 76 52 41 77 78 53 43 44 45 46 79 47))
    (cons (cons 98 (sslength ss)) pickpntlst))))
(entmake MergedHatchList)
)

(defun c:MH ( / hentinfo ss i ent# seedpt# entinfo entinfo2 ent# seedpt# seedpts MergedHatchList)
(while (/= (cdr (assoc 0 hentinfo)) "HATCH")
 (setq hentinfo (car (entsel "\nSelect Hatch Pattern to use:")))
 (If hentinfo (setq hentinfo (entget hentinfo)) (princ "\nMissed. Try again.")))
(while (not ss) (princ "\nSelect hatch entities to merge:")(setq ss (ssget '((0 . "HATCH")))))
(setq MergedHatchList
(list (cons 0 "HATCH")                              
     (cons 100 "AcDbEntity")
     (assoc 8 hentinfo)
     (cons 100 "AcDbHatch")
     (assoc 10 hentinfo)
     (assoc 210 hentinfo)
     (assoc 2 hentinfo)
     (assoc 70 hentinfo)
     (assoc 71 hentinfo)
     (cons 91 (sslength ss))
) i -1 seedpt# 0 ent# 0)
(repeat (sslength ss)
(setq n -1
      entinfo (entget (ssname ss (setq i (1+ i))))
      entinfo2 (member (assoc 92 entinfo) entinfo)
      entinfo2 (reverse (cdr (member (assoc 75 entinfo2)(reverse entinfo2))))
      ent# (+ ent# (cdr (assoc 91 entinfo)))
      seedpt# (+ seedpt# (cdr (assoc 98 entinfo)))
      seedpts (append seedpts (cdr (member (assoc 98 entinfo) entinfo))) 
      MergedHatchList (append MergedHatchList entinfo2)
)
(entdel (ssname ss i))
)
(setq MergedHatchList (subst (cons 91 ent#)(assoc 91 MergedHatchList) MergedHatchList)
     MergedHatchList
(append MergedHatchList
  (append
    (reverse (cdr (member (assoc 98 hentinfo)(reverse (member (assoc 75 hentinfo) hentinfo)))))
    (cons (cons 98 seedpt#) seedpts))))
(entmake MergedHatchList)
)