关于重叠填充的合并问题

Lisphk · 发表于 2016-9-26 14:38:01

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

有段搜集的代码，能合并填充

;; © Juan Villarreal 11.20.2011 ;;;; massoc (Jaysen Long) ;;;; Minor Modification by Jvillarreal ;;;; Extracts info from list by key ;; ;; Found @ http://www.theswamp.org/index.php?topic=40149.0(defun massoc (key alist / x nlist)
(foreach x alist
(if
(eq key (car x))
(setq nlist (cons x nlist))
)
)
(reverse nlist)
) ;defun
(defun c:MergeHatch (/ hentinfo ss i
ent 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)
)
)
)
(if (= (cdr (assoc 71 hentinfo)) 1)
(setq MergedHatchList
(append MergedHatchList
'((-3 ("ACAD" (1010 0.0 0.0 0.0))))
)
)
)
(entmake MergedHatchList)
(setq ent (entlast))
(if (= (cdr (assoc 71 hentinfo)) 1)
(mapcar
'(lambda (x / entlist)
(setq entlist (entget (cdr x)))
(entmod (subst (cons 330 ent) (assoc 330 entlist) entlist))
)
(massoc 330 MergedHatchList)
)
)
)
(defun c:MH () (c:MergeHatch))

;; &#169; Juan Villarreal 11.20.2011 ;;;; massoc (Jaysen Long) ;;;; Minor Modification by Jvillarreal ;;;; Extracts info from list by key ;; ;; Found @ <a href=\"http://www.theswamp.org/index.php?topic=40149.0\" target=\"_blank\">http://www.theswamp.org/index.php?topic=40149.0</a>(defun massoc (key alist / x nlist) 
  (foreach x alist 
    (if 
      (eq key (car x)) 
       (setq nlist (cons x nlist)) 
    ) 
  ) 
  (reverse nlist) 
)                                        ;defun 
(defun c:MergeHatch (/                hentinfo   ss              i 
                     ent        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) 
                          ) 
                        ) 
  ) 
  (if (= (cdr (assoc 71 hentinfo)) 1) 
    (setq MergedHatchList 
           (append MergedHatchList 
                   '((-3 ("ACAD" (1010 0.0 0.0 0.0)))) 
           ) 
    ) 
  ) 
  (entmake MergedHatchList) 
  (setq ent (entlast)) 
  (if (= (cdr (assoc 71 hentinfo)) 1) 
    (mapcar 
      '(lambda (x / entlist) 
         (setq entlist (entget (cdr x))) 
         (entmod (subst (cons 330 ent) (assoc 330 entlist) entlist)) 
       ) 
      (massoc 330 MergedHatchList) 
    ) 
  ) 
) 
(defun c:MH () (c:MergeHatch))

上面代码能完成合并，但是有个问题，如图：

关于重叠填充的合并问题

这个不太符合我们的要求，我们期望合并后应该是这样的：

关于重叠填充的合并问题

如果用AUTOLISP或者VLISP如何实现呢？

qqqincccken · 发表于 2016-9-26 16:52:02

谢谢,期待有大神来解答!!!

newer · 发表于 2016-9-26 16:59:51

思路：
1、求出重叠的边界
2、边界多段线求并生成最外的边界
3、添加LOOP到填充里面，或用这个边界新建个填充。

longer1000 · 发表于 2016-9-26 22:26:21

同求，期待有大神来解答!!!

cable2004 · 发表于 2016-9-27 00:29:28

谢谢,期待有大神来解答!!!

Lispboy · 发表于 2016-9-27 17:09:18

用VLISP简单写了个

(defun c:tt (/ acad acdoc arr bndl e1 e2 ents i lp ms obj x)
(defun _setmark ()
(setq mark (entlast))
)
(defun _getnewentities (/ ents)
(while (setq mark (entnext mark))
(setq ents (cons (vlax-ename->vla-object mark) ents))
)
(setq arr (vlax-make-safearray
vlax-vbobject
(cons 0
(1-
(length ents)
)
)
)
)
(vlax-safearray-fill arr ents)
arr
)
(defun _getbound (obj)
(vla-getloopat obj 0 'lp)
(if (vl-catch-all-error-p
(setq bndl (vl-catch-all-apply
'vlax-safearray->list
(list lp)
)
)
)
(progn
(_setmark)
(command "_-HATCHEDIT"
(vlax-vla-object->ename obj)
"_B"
"_P"
"_Y"
)
(_getnewentities)
)
lp
)
)
(defun _addregion (obj)
(setq objs (_getbound obj))
(vla-addregion ms objs)
(mapcar
'(lambda (x)
(vla-delete x)
)
(vlax-safearray->list objs)
)
(vlax-ename->vla-object (entlast))
)
(if (and
(setq e1 (xd::ssget "\n选取第一个填充<退出>"
'(":E:S" ((0 . "HATCH")))
)
)
(setq o1 (vlax-ename->vla-object (ssname e1 0)))
(setq e2 (xd::ssget "\n选取第二个填充<退出>"
'(":E:S" ((0 . "HATCH")))
)
)
(setq o2 (vlax-ename->vla-object (ssname e2 0)))
)
(progn
(setq acad (vlax-get-acad-object)
acdoc (vla-get-activedocument acad)
ms (vla-get-modelspace acdoc)
)
(setq r1 (_addregion o1)
r2 (_addregion o2)
)
(setq patterntype (vlax-get-property o1 'patterntype)
patternname (vlax-get-property o1 'patternname)
associativehatch (vlax-get-property o1 'associativehatch)
)
(if (not (vl-catch-all-error-p
(vl-catch-all-apply
'vlax-invoke
(list r1
'boolean
acunion
r2
)
)
)
)
(progn
(setq patterntype (vlax-get-property o1 'patterntype)
patternname (vlax-get-property o1 'patternname)
associativehatch (vlax-get-property o1 'associativehatch)
)
(setq hatobj (vla-addhatch
ms
patterntype
patternname
associativehatch
)
)
(vla-put-patternscale
hatobj
(vlax-get-property o1 'patternscale)
)
(vla-appendouterloop
hatobj
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbobject
'
(0 . 0)
)
(list r1)
)
)
)
(vla-evaluate hatobj)
(vla-delete o1)
(vla-delete o2)
(command "regen")
)
)
)
)
(princ)
)

(defun c:tt (/ acad acdoc arr bndl e1 e2 ents i lp ms obj x) 
  (defun _setmark () 
    (setq mark (entlast)) 
  ) 
  (defun _getnewentities (/ ents) 
    (while (setq mark (entnext mark)) 
      (setq ents (cons (vlax-ename->vla-object mark) ents)) 
    ) 
    (setq arr (vlax-make-safearray 
    vlax-vbobject 
    (cons 0 
          (1- 
      (length ents) 
          ) 
    ) 
        ) 
    ) 
    (vlax-safearray-fill arr ents) 
    arr 
  ) 
  (defun _getbound (obj) 
    (vla-getloopat obj 0 'lp) 
    (if  (vl-catch-all-error-p 
    (setq  bndl (vl-catch-all-apply 
           'vlax-safearray->list 
           (list lp) 
         ) 
    ) 
  ) 
      (progn 
  (_setmark) 
  (command "_-HATCHEDIT" 
     (vlax-vla-object->ename obj) 
     "_B" 
     "_P" 
     "_Y" 
  ) 
  (_getnewentities) 
      ) 
      lp 
    ) 
  ) 
  (defun _addregion (obj) 
    (setq objs (_getbound obj)) 
    (vla-addregion ms objs) 
    (mapcar 
      '(lambda (x) 
   (vla-delete x) 
       ) 
      (vlax-safearray->list objs) 
    ) 
    (vlax-ename->vla-object (entlast)) 
  ) 
  (if (and 
  (setq e1 (xd::ssget "\n选取第一个填充<退出>" 
          '(":E:S" ((0 . "HATCH"))) 
     ) 
  ) 
  (setq o1 (vlax-ename->vla-object (ssname e1 0))) 
  (setq e2 (xd::ssget "\n选取第二个填充<退出>" 
          '(":E:S" ((0 . "HATCH"))) 
     ) 
  ) 
  (setq o2 (vlax-ename->vla-object (ssname e2 0))) 
      ) 
    (progn 
      (setq acad  (vlax-get-acad-object) 
      acdoc (vla-get-activedocument acad) 
      ms    (vla-get-modelspace acdoc) 
      ) 
      (setq r1 (_addregion o1) 
      r2 (_addregion o2) 
      ) 
      (setq patterntype       (vlax-get-property o1 'patterntype) 
      patternname       (vlax-get-property o1 'patternname) 
      associativehatch (vlax-get-property o1 'associativehatch) 
      ) 
      (if (not (vl-catch-all-error-p 
     (vl-catch-all-apply 
       'vlax-invoke 
       (list r1 
       'boolean 
       acunion 
       r2 
       ) 
     ) 
         ) 
    ) 
  (progn 
    (setq  patterntype   (vlax-get-property o1 'patterntype) 
    patternname   (vlax-get-property o1 'patternname) 
    associativehatch (vlax-get-property o1 'associativehatch) 
    ) 
    (setq  hatobj (vla-addhatch 
       ms 
       patterntype 
       patternname 
       associativehatch 
           ) 
    ) 
    (vla-put-patternscale 
      hatobj 
      (vlax-get-property o1 'patternscale) 
    ) 
    (vla-appendouterloop 
      hatobj 
      (vlax-make-variant 
        (vlax-safearray-fill 
    (vlax-make-safearray 
      vlax-vbobject 
      ' 
       (0 . 0) 
    ) 
    (list r1) 
        ) 
      ) 
    ) 
    (vla-evaluate hatobj) 
    (vla-delete o1) 
    (vla-delete o2) 
    (command "regen") 
  ) 
      ) 
    ) 
  ) 
  (princ) 
)

Lispboy · 发表于 2016-9-27 17:17:50

好久不用VLISP写代码了，VLISP太累了，下面代码用XDRX API，顺手，完成同样的事。

(defun c:XDTB_HatchUnion ( / c c1 c2 e1 e2 ss ss1 ss2)
(if (and
(setq e1 (car (xdrx_entsel "\n选取主色块<退出>:" '((0 . "HATCH")))))
(xdrx_pickset_redraw e1 3)
(setq e2 (car (xdrx_entsel "\n选取要合并的色块<退出>:" '((0 .
"HATCH"
)
)
)
)
)
(not (eq e1 e2))
)
(progn
(XD::Begin)
(if (xdrx_entity_boundingBoxIntersectwith e1 e2)
(progn
(setq ss1 (xdrx_hatch_ExternalLoopMake e1)
c1 (ssname ss1 0)
ss2 (xdrx_hatch_ExternalLoopMake e2)
c2 (ssname ss2 0)
)
(if (setq ss (xdrx_curve_union c1 c2 0))
(progn
(setq c (xdrx_hatch_make ss))
(XD::HATCH:MATCHFROM c e1)
(xdrx_entity_delete e1 e2 c1 c2)
(prompt "\n成功合并了两个色块。")
)
)
)
(prompt "\n两个色块不相交，不能合并。")
)
(XD::End)
)
)
(princ)
)

(defun c:XDTB_HatchUnion ( / c c1 c2 e1 e2 ss ss1 ss2) 
  (if (and 
  (setq e1 (car (xdrx_entsel "\n选取主色块<退出>:" '((0 . "HATCH"))))) 
  (xdrx_pickset_redraw e1 3) 
  (setq e2 (car (xdrx_entsel "\n选取要合并的色块<退出>:" '((0 . 
                    "HATCH" 
                 ) 
           ) 
          ) 
     ) 
  ) 
  (not (eq e1 e2)) 
      ) 
    (progn 
      (XD::Begin) 
      (if (xdrx_entity_boundingBoxIntersectwith e1 e2) 
  (progn 
    (setq ss1 (xdrx_hatch_ExternalLoopMake e1) 
    c1 (ssname ss1 0) 
    ss2 (xdrx_hatch_ExternalLoopMake e2) 
    c2 (ssname ss2 0) 
    ) 
    (if (setq ss (xdrx_curve_union c1 c2 0)) 
      (progn 
        (setq c (xdrx_hatch_make ss)) 
        (XD::HATCH:MATCHFROM c e1) 
        (xdrx_entity_delete e1 e2 c1 c2) 
        (prompt "\n成功合并了两个色块。") 
      ) 
    ) 
 
  ) 
  (prompt "\n两个色块不相交，不能合并。") 
      ) 
      (XD::End) 
    ) 
  ) 
  (princ) 
)

账号		自动登录	找回密码
密码			立即注册

[研讨] 关于重叠填充的合并问题

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。