Topic: duplicated hatch area delete way

[dussla]

sorry freinds ~ i need  help again   
sorry many ask ~ forgive me

there is  very  big hatch area
attached  image is very simple example

there is overlapping hatch (=duplicate hatch)

i would like to  delete all  duplicate area

no overkill  ~~
both delete way
can you understand my attached image ~

[dussla]

sorry freinds ~ i need  help again   
sorry many ask ~ forgive me

there is  very  big hatch area
attached  image is very simple example

there is overlapping hatch (=duplicate hatch)

i would like to  delete all  duplicate area

no overkill  ~~
both delete way
can you understand my attached image ~

dwg file

[ribarm]

What if green hatch only partially cover underneath hatches, delete them anyway - both green and one under?

[ribarm]

Here you go...

Code - Auto/Visual Lisp: [Select]

1. (defun c:deleteoverlappedhatches ( / adoc ss n i ha bl k dx p pl hl )
2.  
3.   (vl-load-com)
4.  
5.   (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
6.   (vla-endundomark adoc)
7.   (vla-startundomark adoc)
8.   (setq ss (ssget "_:L" '((0 . "HATCH") (2 . "SOLID"))))
9.   (if ss
10.     (progn
11.       (initget 7)
12.       (setq n (getint "\nNumber of iterations - checks from outside to inner area : "))
13.       (repeat (setq i (sslength ss))
14.         (setq ha (ssname ss (setq i (1- i))))
15.         (vl-cmdf "_.-HATCHEDIT" ha "_B" "_P" "_N")
16.         (setq bl (cons (list (entlast) ha) bl))
17.       )
18.       (repeat n
19.         (foreach b bl
20.           (if (not (vlax-erased-p (car b)))
21.             (progn
22.               (setq k -1)
23.               (setq dx (/ (vlax-curve-getdistatparam (car b) (vlax-curve-getendparam (car b))) 100.))
24.               (repeat 100
25.                 (setq p (vlax-curve-getpointatdist (car b) (* dx (setq k (1+ k)))))
26.                 (setq pl (cons p pl))
27.               )
28.               (if (vl-some '(lambda ( x ) (= (sslength (ssget "_C" x x)) 2)) pl)
29.                 (setq hl (cons b hl))
30.               )
31.               (setq pl nil)
32.             )
33.           )
34.         )
35.         (foreach e (apply 'append hl)
36.           (entdel e)
37.         )
38.         (setq hl nil)
39.       )
40.       (foreach b bl
41.         (entdel (cadr b))
42.       )
43.       (foreach b (mapcar 'car bl)
44.         (if (not (vlax-erased-p b))
45.           (entdel b)
46.         )
47.       )
48.     )
49.   )
50.   (vla-regen adoc acactiveviewport)
51.   (vla-endundomark adoc)
52.   (princ)
53. )
54.  

HTH., M.R.

[ronjonp]

Here's another way ( based off of example drawing )

Code - Auto/Visual Lisp: [Select]

1. (defun c:foo (/ _apl f e s)
2.   ;; RJP - 04-04-2018
3.   ;; Deletes overlapping hatches with common centroids
4.   (defun _apl (l) (mapcar '(lambda (x) (/ x (length l))) (apply 'mapcar (cons '+ l))))
5.   ;; Fuzz value '20000' below set from drawing example .. may need to adjust for different scenarios
6.   (setq f 20000.)
7.   (cond ((setq s (ssget ":L" '((0 . "hatch"))))
8.          (setq s
9.                 (mapcar
10.                   '(lambda (x)
11.                      (list x
12.                            (_apl (mapcar 'cdr
13.                                          (vl-remove-if
14.                                            '(lambda (d) (or (equal '(0.0 0.0 0.0) (cdr d)) (/= 10 (car d))))
15.                                            (entget x)
16.                                          )
17.                                  )
18.                            )
19.                      )
20.                    )
21.                   (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
22.                 )
23.          )
24.          (while (setq e (car s))
25.            (setq s (cdr s))
26.            (if (setq tmp (vl-remove-if-not '(lambda (x) (equal (cadr e) (cadr x) f)) s))
27.              (progn (mapcar 'entdel (mapcar 'car tmp))
28.                     (entdel (car e))
29.                     (mapcar '(lambda (x) (grdraw (cadr e) (cadr x) 3) (setq s (vl-remove x s))) tmp)
30.              )
31.            )
32.          )
33.         )
34.   )
35.   (princ)
36. )

[dussla]

Here's another way ( based off of example drawing )

Code - Auto/Visual Lisp: [Select]

1. (defun c:foo (/ _apl f e s)
2.   ;; RJP - 04-04-2018
3.   ;; Deletes overlapping hatches with common centroids
4.   (defun _apl (l) (mapcar '(lambda (x) (/ x (length l))) (apply 'mapcar (cons '+ l))))
5.   ;; Fuzz value '20000' below set from drawing example .. may need to adjust for different scenarios
6.   (setq f 20000.)
7.   (cond ((setq s (ssget ":L" '((0 . "hatch"))))
8.          (setq s
9.                 (mapcar
10.                   '(lambda (x)
11.                      (list x
12.                            (_apl (mapcar 'cdr
13.                                          (vl-remove-if
14.                                            '(lambda (d) (or (equal '(0.0 0.0 0.0) (cdr d)) (/= 10 (car d))))
15.                                            (entget x)
16.                                          )
17.                                  )
18.                            )
19.                      )
20.                    )
21.                   (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
22.                 )
23.          )
24.          (while (setq e (car s))
25.            (setq s (cdr s))
26.            (if (setq tmp (vl-remove-if-not '(lambda (x) (equal (cadr e) (cadr x) f)) s))
27.              (progn (mapcar 'entdel (mapcar 'car tmp))
28.                     (entdel (car e))
29.                     (mapcar '(lambda (x) (grdraw (cadr e) (cadr x) 3) (setq s (vl-remove x s))) tmp)
30.              )
31.            )
32.          )
33.         )
34.   )
35.   (princ)
36. )

good
i test this file
but that is not work ~~

[dussla]

Here's another way ( based off of example drawing )

Code - Auto/Visual Lisp: [Select]

1. (defun c:foo (/ _apl f e s)
2.   ;; RJP - 04-04-2018
3.   ;; Deletes overlapping hatches with common centroids
4.   (defun _apl (l) (mapcar '(lambda (x) (/ x (length l))) (apply 'mapcar (cons '+ l))))
5.   ;; Fuzz value '20000' below set from drawing example .. may need to adjust for different scenarios
6.   (setq f 20000.)
7.   (cond ((setq s (ssget ":L" '((0 . "hatch"))))
8.          (setq s
9.                 (mapcar
10.                   '(lambda (x)
11.                      (list x
12.                            (_apl (mapcar 'cdr
13.                                          (vl-remove-if
14.                                            '(lambda (d) (or (equal '(0.0 0.0 0.0) (cdr d)) (/= 10 (car d))))
15.                                            (entget x)
16.                                          )
17.                                  )
18.                            )
19.                      )
20.                    )
21.                   (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
22.                 )
23.          )
24.          (while (setq e (car s))
25.            (setq s (cdr s))
26.            (if (setq tmp (vl-remove-if-not '(lambda (x) (equal (cadr e) (cadr x) f)) s))
27.              (progn (mapcar 'entdel (mapcar 'car tmp))
28.                     (entdel (car e))
29.                     (mapcar '(lambda (x) (grdraw (cadr e) (cadr x) 3) (setq s (vl-remove x s))) tmp)
30.              )
31.            )
32.          )
33.         )
34.   )
35.   (princ)
36. )

good
i test this file
but that is not work ~~

dwg file

[ronjonp]

Here's another way ( based off of example drawing )

Code - Auto/Visual Lisp: [Select]

1. (defun c:foo (/ _apl f e s)
2.   ;; RJP - 04-04-2018
3.   ;; Deletes overlapping hatches with common centroids
4.   (defun _apl (l) (mapcar '(lambda (x) (/ x (length l))) (apply 'mapcar (cons '+ l))))
5.   ;; Fuzz value '20000' below set from drawing example .. may need to adjust for different scenarios
6.   (setq f 20000.)
7.   (cond   ((setq s (ssget ":L" '((0 . "hatch"))))
8.     (setq s
9.       (mapcar
10.         '(lambda (x)
11.            (list x
12.             (_apl (mapcar 'cdr
13.                 (vl-remove-if
14.                   '(lambda (d) (or (equal '(0.0 0.0 0.0) (cdr d)) (/= 10 (car d))))
15.                   (entget x)
16.                 )
17.              )
18.             )
19.            )
20.          )
21.         (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
22.       )
23.     )
24.     (while   (setq e (car s))
25.       (setq s (cdr s))
26.       (if (setq tmp (vl-remove-if-not '(lambda (x) (equal (cadr e) (cadr x) f)) s))
27.         (progn (mapcar 'entdel (mapcar 'car tmp))
28.           (entdel (car e))
29.           (mapcar '(lambda (x) (grdraw (cadr e) (cadr x) 3) (setq s (vl-remove x s))) tmp)
30.         )
31.       )
32.     )
33.    )
34.   )
35.   (princ)
36. )

good
i test this file
but that is not work ~~

dwg file

You should have posted your actual drawing ... Sorry not enough time right now to figure this one out. Maybe ribarms code will do.

[dussla]

Really sorry  my poor explain about my work
I receved this plan often
Red  is road
Gray is  earth

Earth hatch   exsit all region
For my work    i need   earth hatch -  road hatch
Then i can get  pure earth region  ~~~

[ribarm]

Ron's method is good, but the DWG is very demandable... So this is something between Ron's code and my version... It could get you some results as I've checked for fuzziness and hard coded it into lisp... Of course, only on your DWG...

Code - Auto/Visual Lisp: [Select]

1. (defun c:deleteoverlappedhatches ( / _apl adoc ss i ha el s enx bl hl )
2.  
3.   (vl-load-com)
4.  
5.   (defun _apl ( l ) (mapcar '(lambda ( x ) (/ x (length l))) (apply 'mapcar (cons '+ l))))
6.  
7.   (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
8.   (vla-endundomark adoc)
9.   (vla-startundomark adoc)
10.   (setq ss (ssget "_:L" '((0 . "HATCH") (2 . "SOLID"))))
11.   (if ss
12.     (progn
13.       (repeat (setq i (sslength ss))
14.         (setq ha (ssname ss (setq i (1- i))))
15.         (setq el (entlast) s (ssadd))
16.         (vl-cmdf "_.-HATCHEDIT" ha "_B" "_P" "_N")
17.         (while (setq el (entnext el))
18.           (ssadd el s)
19.         )
20.         (vl-cmdf "_.PEDIT" "_M" s "" "_J" "_J" "_E" 10000.0)
21.         (while (< 0 (getvar 'cmdactive)) (vl-cmdf ""))
22.         (if (= 0 (logand 1 (cdr (assoc 70 (setq enx (entget (entlast)))))))
23.           (entmod (setq enx (subst (cons 70 (1+ (cdr (assoc 70 enx)))) (assoc 70 enx) enx)))
24.         )
25.         (setq bl (cons (list (_apl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) enx))) (entlast) ha) bl))
26.       )
27.       (foreach b bl
28.         (if (vl-some '(lambda ( x ) (and (equal (vlax-curve-getarea (cadr b)) (vlax-curve-getarea (cadr x)) 1e+9) (< (distance (car b) (car x)) 3.6e+4))) (vl-remove b bl)) ;;; change 1e+9 and 3.6e+4 to suit DWG
29.           (setq hl (cons b hl))
30.         )
31.       )
32.       (foreach e (mapcar 'caddr hl)
33.         (entdel e)
34.       )
35.       (foreach b bl
36.         (entdel (cadr b))
37.       )
38.     )
39.   )
40.   (vla-regen adoc acactiveviewport)
41.   (vla-endundomark adoc)
42.   (princ)
43. )
44.  

M.R.

[dussla]

Ron's method is good, but the DWG is very demandable... So this is something between Ron's code and my version... It could get you some results as I've checked for fuzziness and hard coded it into lisp... Of course, only on your DWG...

Code - Auto/Visual Lisp: [Select]

1. (defun c:deleteoverlappedhatches ( / _apl adoc ss i ha el s enx bl hl )
2.  
3.   (vl-load-com)
4.  
5.   (defun _apl ( l ) (mapcar '(lambda ( x ) (/ x (length l))) (apply 'mapcar (cons '+ l))))
6.  
7.   (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
8.   (vla-endundomark adoc)
9.   (vla-startundomark adoc)
10.   (setq ss (ssget "_:L" '((0 . "HATCH") (2 . "SOLID"))))
11.   (if ss
12.     (progn
13.       (repeat (setq i (sslength ss))
14.         (setq ha (ssname ss (setq i (1- i))))
15.         (setq el (entlast) s (ssadd))
16.         (vl-cmdf "_.-HATCHEDIT" ha "_B" "_P" "_N")
17.         (while (setq el (entnext el))
18.           (ssadd el s)
19.         )
20.         (vl-cmdf "_.PEDIT" "_M" s "" "_J" "_J" "_E" 10000.0)
21.         (while (< 0 (getvar 'cmdactive)) (vl-cmdf ""))
22.         (if (= 0 (logand 1 (cdr (assoc 70 (setq enx (entget (entlast)))))))
23.           (entmod (setq enx (subst (cons 70 (1+ (cdr (assoc 70 enx)))) (assoc 70 enx) enx)))
24.         )
25.         (setq bl (cons (list (_apl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) enx))) (entlast) ha) bl))
26.       )
27.       (foreach b bl
28.         (if (vl-some '(lambda ( x ) (and (equal (vlax-curve-getarea (cadr b)) (vlax-curve-getarea (cadr x)) 1e+9) (< (distance (car b) (car x)) 3.6e+4))) (vl-remove b bl)) ;;; change 1e+9 and 3.6e+4 to suit DWG
29.           (setq hl (cons b hl))
30.         )
31.       )
32.       (foreach e (mapcar 'caddr hl)
33.         (entdel e)
34.       )
35.       (foreach b bl
36.         (entdel (cadr b))
37.       )
38.     )
39.   )
40.   (vla-regen adoc acactiveviewport)
41.   (vla-endundomark adoc)
42.   (princ)
43. )
44.  

M.R.

wow wow
i tested this code
90% is sucess~~
perpect  , really really thank you for your effor
again thank you ~~

[ronjonp]

Had a little bit of time .. here's another way to do it ( not 100% )  That drawing is a mess!

Code - Auto/Visual Lisp: [Select]

1. (defun c:foo (/ b c e f ll s ur)
2.   ;; RJP - 04-05-2018
3.   ;; Deletes overlapping hatches with somewhat common bounding boxes
4.   (setq f 500)
5.   (cond ((setq s (ssget ":L" '((0 . "hatch"))))
6.          (setq s (mapcar '(lambda (x)
7.                             (vla-getboundingbox (vlax-ename->vla-object x) 'll 'ur)
8.                             (cons x (mapcar 'vlax-safearray->list (list ll ur)))
9.                           )
10.                          (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
11.                  )
12.          )
13.          (while (setq e (car s))
14.            (setq s (cdr s))
15.            (setq b (cdr e))
16.            (if (setq c
17.                       (vl-remove-if-not
18.                         '(lambda (x) (and (equal (car b) (car (cdr x)) f) (equal (cadr b) (cadr (cdr x)) f)))
19.                         s
20.                       )
21.                )
22.              (progn (mapcar 'entdel (mapcar 'car c))
23.                     (entdel (car e))
24.                     (mapcar '(lambda (x) (setq s (vl-remove x s))) c)
25.              )
26.            )
27.          )
28.         )
29.   )
30.   (princ)
31. )

[dussla]

my client give  mess plan always
Sometimes it goes crazy.
really thank you for your effor
I think
Maybe you are a genius sometimes