Separate Hatches on multiple Layers depending on Color or Name

[braudpat]

Hello

I have not found the magic routine !

Please I need a Lisp routine to separate Hatch depending on Colors or on Names

So I see the routine like :

- Classic ACAD selection

- Keep into the selection ONLY Hatch Object

- Question: Separate by Color (Default) or by Name ?

- Process the 1st Hatch and create (Make Layer) based on the layer hatch "XXXXXX"

==== If Color Separation ====

If standard Color (0-256), Layer Name  : XXXXXX___NNN  (where NNN is 0-256)

( I would like 3 numbers if possible !? )

If RGB Color , Layer Name : XXXXXX___RRR_GGG_BBB

( I would like 3 x 3 numbers if possible !? )

==== If Name Separation ====

Layer name : XXXXXX___ANSI31 , XXXXXX___SOLID , etc

Process the next Hatch ...

Do you see what I mean ? ... Thanks in advance ...

The sample DWG would help you ...

THE HEALTH, Regards, Patrice (The Old French EE Froggy)

I am hidden into my bunker ...

[dlanorh]

Any Color Book colors?

[dlanorh]

1. Does the new layer need a color?

2. Is the hatch to be put on the new layer?

[braudpat]

Hello

1) YES ALL the Hatch has to be moved to the New Layer

2) What do you mean by color book : Pantone, RAL, etc ?

If YES and if it is not a big effort to manage these special colors :

Create and Use a layer named :  XXXXXX___ColorBookName

3) The NEW layer must have the default Color & LineType & LineWeight of the original hatch layer

4) The moved Hatch have to keep their original color : ByLayer, ByBlock, 0-256, RGB, etc ...

and original LineType and original LineWeight ...

So their new display will be the same before !?

Thanks, Regards, Patrice

[dlanorh]

I'm sure this will need tweaking, but try this.

(defun LM:True->RGB ( c ) (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(8 16 24)))

(defun rh:lst2str ( lst del / str) (setq str "")  (mapcar '(lambda (x) (setq str (strcat str x del))) lst) (vl-string-right-trim del str))

(defun rh:layer_props ( lyr lst / v ) (setq v (mapcar '(lambda (x) (vlax-get-property lyr x)) lst)))

(defun c:hatchlayers ( / c_doc c_lyrs l_props ans ss cnt ent elst lyr l_vals hn cstr clst clr nlyr lobj)

  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_lyrs (vla-get-layers c_doc)
        l_props (list 'truecolor 'linetype 'lineweight)
  );end_setq

  (initget "Color Name")
  (setq ans (cond ( (getkword "\nSeparate Hatches by : [Color/Name] <Color> ")) ("Color")))
  
  (setq ss (ssget "_X" '((0 . "HATCH"))))
  (cond (ss
          (repeat (setq cnt (sslength ss))
            (setq ent (ssname ss (setq cnt (1- cnt)))
                  elst (entget ent)
                  lyr (cdr (assoc 8 elst))
                  l_vals (rh:layer_props (vla-item c_lyrs lyr) l_props)
                  hn  (cdr (assoc 2 elst))
                  cstr ""
            );end_setq
            (cond ( (= ans "Color")
                    (foreach x '(62 420 430) (setq clst (cons (cdr (assoc x elst)) clst)))
                    (setq clr (vl-some '(lambda (x) x) clst))
                    (cond ( (and (= (type clr) 'INT) (<= clr 256)) (setq cstr (itoa clr))(while (< (strlen cstr) 3) (setq cstr (strcat "0" cstr))))
                          ( (= (type clr) 'STR) (setq cstr clr))
                          (t (setq clr (mapcar 'itoa (LM:True->RGB clr))
                                   clr (mapcar '(lambda (x) (if (< (strlen x) 3) (while (< (strlen x) 3) (setq x (strcat "0" x))) x)) clr)
                                   cstr (rh:lst2str clr "_")
                             );end_setq
                          )
                    );end_cond
                    (setq nlyr (strcat lyr "__" cstr))
                  )
                  (t (setq nlyr (strcat lyr "__" hn)))
            );end_cond
            (cond ( (not (tblsearch "layer" nlyr)) (setq lobj (vla-add c_lyrs nlyr)) (mapcar '(lambda (x y) (vlax-put-property lobj x y)) l_props l_vals)))
            (vlax-put-property (vlax-ename->vla-object ent) 'layer nlyr)
          );end_repeat
        )
        (t (alert "NO Hatches Found"))
  );end_cond
  (princ)
);end_defun

[braudpat]

Hello

WAOUH I have to do some other intensive tests with a much more complex DWG !

But the actual routine seems OK ! ... I removed the "_X" to get standard selection ...

Question: if the HATCH Color is ByLayer or ByBlock, I get always 000 !

Is it normal ?? ByBlock is not 256 !?

Thanks, I appreciate your effort ! ... Tomorrow, I will do other tests ...

Beautiful use of mapcar , lambda , etc ... Far beyond my poor Lisp knowledge !

THE HEALTH, Regards, Patrice

[dlanorh]

---

@braudpat wrote:

Question: if the HATCH Color is ByLayer or ByBlock, I get always 000 !

Is it normal ?? ByBlock is not 256 !?

---

It should give byblock "000" and bylayer "256". I tested byblock, but not bylayer. I will check tomorrow.

---

Beautiful use of mapcar , lambda , etc ... Far beyond my poor Lisp knowledge !

---

I'm still learning what is possible, but thanks. 😁

[dlanorh · Accepted solution]

Attempt 2. The problem with bylayer was I forgot to allow for the default (no 62 code).

One question, what do you want to do with the hatch boundary (if present)? It's accessable if there.

(defun LM:True->RGB ( c ) (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(8 16 24)))

(defun rh:lst2str ( lst del / str ) (setq str "")  (mapcar '(lambda (x) (setq str (strcat str x del))) lst) (vl-string-right-trim del str))

(defun rh:layer_props ( lyr lst / v ) (setq v (mapcar '(lambda (x) (vlax-get-property lyr x)) lst)))

(defun rh:strlen3 ( str ) (if (< (strlen str) 3) (while (< (strlen str) 3) (setq str (strcat "0" str))) str) str)

(defun c:hatchlayers ( / c_doc c_lyrs l_props ans ss cnt ent elst lyr l_vals hn cstr clst clr nlyr lobj)

  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_lyrs (vla-get-layers c_doc)
        l_props (list 'truecolor 'linetype 'lineweight);Layer properties list
  );end_setq

  (initget "Color Name")
  (setq ans (cond ( (getkword "\nSeparate Hatches by : [Color/Name] <Color> ")) ("Color")))

  (prompt "\nSelect Hatches : ")
  (setq ss (ssget '((0 . "HATCH"))))

  (cond (ss
          (repeat (setq cnt (sslength ss))
            (setq ent (ssname ss (setq cnt (1- cnt)))
                  elst (entget ent)
                  lyr (cdr (assoc 8 elst));Layer
                  l_vals (rh:layer_props (vla-item c_lyrs lyr) l_props);Layer properties
                  hn  (cdr (assoc 2 elst));Hatch pattern name
                  cstr ""
                  clst nil
            );end_setq

            (cond ( (= ans "Color")
                    (foreach x '(62 420 430) (setq clst (cons (cdr (assoc x elst)) clst)))
                    (setq clr (vl-some '(lambda (x) x) clst))
                    (cond ( (not clr) (setq cstr "256"))                ;No Color set (bylayer)
                          ( (and (= (type clr) 'INT) (<= clr 256))      ;ACI (0-256)
                            (setq cstr (rh:strlen3 (itoa clr)))
                          )
                          ( (= (type clr) 'STR) (setq cstr clr))        ;Color Book
                          (t (setq clr (mapcar 'itoa (LM:True->RGB clr));RGB
                                   cstr (rh:lst2str (mapcar 'rh:strlen3 clr) "_")
                             );end_setq
                          )
                    );end_cond
                    (setq nlyr (strcat lyr "__" cstr))
                  )
                  (t (setq nlyr (strcat lyr "__" hn)))
            );end_cond

            (cond ( (not (tblsearch "layer" nlyr)) (setq lobj (vla-add c_lyrs nlyr)) (mapcar '(lambda (x y) (vlax-put-property lobj x y)) l_props l_vals)))
            (vlax-put-property (vlax-ename->vla-object ent) 'layer nlyr)
          );end_repeat
        )
        (t (alert "NO Hatches Found"))
  );end_cond

  (princ)
);end_defun

[braudpat]

Hello @dlanorh 

1) BRAVO ! BRAVISSIMO !

2) ByBlock = 000 and ByLayer = 256 !!

3) Even Color Books are OK !!!

4) I have joined my latest DWG Test (more cases) ... For Tests ...

5) What do you mean with Hatch Boundaries ?

If they are present !?

I imagine maybe with 2 new questions !?

5 - Q1) Process Boundaries (Yes/No) - Default = No

5 - Q2) Copy or Move Boundaries (Yes/No) - Default = Copy

Do you think it's possible without big effort !?

Maybe KEEP your effort for others demands because it's not my primary demand !!

THANKS AGAIN, THE HEALTH, Regards, Patrice (The Old French EE Froggy)

Hidden into its bunker

[dlanorh]

---

5) What do you mean with Hatch Boundaries ?

If they are present !?

---

You can have a hatch without a boundary, if it has been deleted. Finding out if the boundary is there is simple. I was thinking along the lines of changing the boundary to the same layer as the hatch, or copy and change if it is not on the same layer as the hatch.

---

5 - Q1) Process Boundaries (Yes/No) - Default = No

5 - Q2) Copy or Move Boundaries (Yes/No) - Default = Copy

Do you think it's possible without big effort !?

---

OK

5.1  Define "Process" Boundaries. Would this be change their layer?

5.2 I don't fully understand this. Please explain in greater detail.

[braudpat]

Hello

5.1 Process Boundaries (Yes/No) - Default = No

Would this be change their layer ?

5.2 Copy or Move Boundaries (Yes/No) - Default = Copy

I don't fully understand this ... Please explain in greater detail.

---- OOPS SORRY my words were mysterious ! In fact that I imagine is :

- If the Boundary exists, COPY it to the new layer ...

- If the Boundary doesn't exist, RECREATE it to the new layer ...

Please remind that the aspect (of the boundary) must be the same : Color, LineType, LineWeight, Transparency, ...

Do you think it is not too complex to add this feature to YOUR BEAUTIFUL Routine !?

Beware of that into my DWG test , there are ONLY Hatches (No Boundary) ...

Thanks for your attention, THE HEALTH, Regards, Patrice

[dlanorh]

OK. I'll see what I can do. Doesn't look too difficult. (touch wood and putting hand to head). 😅

[dlanorh]

Latest Code. This recreates the boundary on the hatches new layer (where there is no associated boundary), and copies the exiting boundary then moves the original boundary to the hatch layer. Please check that this works a required.

Stay safe.

(defun LM:True->RGB ( c ) (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(8 16 24)))

(defun rh:lst2str ( lst del / str ) (setq str "")  (mapcar '(lambda (x) (setq str (strcat str x del))) lst) (vl-string-right-trim del str))

(defun rh:layer_props ( lyr lst / v ) (setq v (mapcar '(lambda (x) (vlax-get-property lyr x)) lst)))

(defun rh:strlen3 ( str ) (if (< (strlen str) 3) (while (< (strlen str) 3) (setq str (strcat "0" str))) str) str)

(defun rh:hatchbound-p (lst) (cadr (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 330)) lst))))

(defun rh:rhb (ent lyr) (setvar 'clayer lyr) (command "_.-HATCHEDIT" ent "_B" "_R" "_Y"))

(defun c:hatchlayers ( / *error* c_doc c_lyrs sv_lst sv_vals l_props ans ss cnt ent elst lyr l_vals hn cstr clst clr nlyr lobj b_lst m_lst bobj)

  (defun *error* ( msg )
    (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
    (mapcar 'setvar sv_lst sv_vals)
    (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nOops an Error : " msg " occurred.")))
    (princ)
  );_end_*error*_defun

  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_lyrs (vla-get-layers c_doc)
        sv_lst (list 'cmdecho 'osmode 'hpbound 'clayer)
        sv_vals (mapcar 'getvar sv_lst)
        l_props (list 'truecolor 'linetype 'lineweight);Layer properties list
  );end_setq

  (mapcar 'setvar sv_lst '(0 0 0))

  (initget "Color Name")
  (setq ans (cond ( (getkword "\nSeparate Hatches by : [Color/Name] <Color> ")) ("Color")))

  (prompt "\nSelect Hatches : ")
  (setq ss (ssget '((0 . "HATCH"))))

  (cond (ss
          (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
          (vla-startundomark c_doc)
          (repeat (setq cnt (sslength ss))
            (setq ent (ssname ss (setq cnt (1- cnt)))
                  elst (entget ent)
                  lyr (cdr (assoc 8 elst));Layer
                  l_vals (rh:layer_props (vla-item c_lyrs lyr) l_props);Layer properties
                  hn  (cdr (assoc 2 elst));Hatch pattern name
                  cstr ""
                  clst nil
            );end_setq

            (cond ( (= ans "Color")
                    (foreach x '(62 420 430) (setq clst (cons (cdr (assoc x elst)) clst)))
                    (setq clr (vl-some '(lambda (x) x) clst))
                    (cond ( (not clr) (setq cstr "256"))                ;No Color set (bylayer)
                          ( (and (= (type clr) 'INT) (<= clr 256))      ;ACI (0-256)
                            (setq cstr (rh:strlen3 (itoa clr)))
                          )
                          ( (= (type clr) 'STR) (setq cstr clr))        ;Color Book
                          (t (setq clr (mapcar 'itoa (LM:True->RGB clr));RGB
                                   cstr (rh:lst2str (mapcar 'rh:strlen3 clr) "_")
                             );end_setq
                          )
                    );end_cond
                    (setq nlyr (strcat lyr "__" cstr))
                  )
                  (t (setq nlyr (strcat lyr "__" hn)))
            );end_cond

            (cond ( (not (tblsearch "layer" nlyr)) (setq lobj (vla-add c_lyrs nlyr)) (mapcar '(lambda (x y) (vlax-put-property lobj x y)) l_props l_vals)))
            (vlax-put-property (vlax-ename->vla-object ent) 'layer nlyr)
            (if (= 0 (cdr (assoc 71 elst))) (setq b_lst (cons (list ent nlyr) b_lst)) (setq m_lst (cons (list ent nlyr) m_lst)))
          );end_repeat
          (if b_lst (foreach x b_lst (rh:rhb (car x) (cadr x))))
          (cond (m_lst 
                  (foreach y m_lst
                    (setq bobj (vlax-ename->vla-object (cadr (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 330)) (entget (car y)))))))
                    (vla-copy bobj)
                    (vlax-put-property bobj 'layer (cadr y))
                  );end_foreach
                )
          );end_cond
        )
        (t (alert "NO Hatches Found"))
  );end_cond

  (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
  (mapcar 'setvar sv_lst sv_vals)
  (vla-regen c_doc acAllViewports)
  (princ)
);end_defun

[braudpat]

Hello @dlanorh 

Please is it possible to ask something a little bit different but very near !

I have joined the version 1.1 of your beautiful routine which separates hatches (without recreating Boudaries) on many layers depending on either Color or either Hatch Name ...

Because I imagine that the new routine will be very similar !?

I would like the same routine to process only for COLOR (So NO question !) but on ANY Entity :

line, arc, 2D pline heavy or light, 3D pline, circle, ellipse, region, spline, mpolygon, text, mtext, mline, dim, hatch, 3DSolid, 3DSurface, 3DFace, 3DPolyMesh, etc ...

Thanks in advance, THE HEALTH (Stay Safe), Regards, Patrice

[dlanorh]

I think I understand this, will give it ago over the next couple of days.

[braudpat]

Hello

Thanks for your future efforts !

Please with a standard ACAD selection : all ACAD entities from the selection on unlocked layers ...

THE HEALTH (Stay Safe), Regards, Patrice (The Old French EE Froggy)

Hidden into my bunker ...

[dlanorh · Accepted solution]

Initial attempt attached. 😁

Not tested as I only have AutoCAD LT with me at present.

[braudpat]

Hello Mr @dlanorh 

WAOUH Fabulous / Excellent / BRAVO ! ... Your routine is very COMPACT / SHORT !!

I have attached my 2 DWGs :

- ENTITES_2004_1_ORIGINAL  :  the Original Test DWG (with almost ALL entities)

- ENTITES_2004_2_E2LBC  :  the DWG after processing by E2LBC

THANKS, THE HEALTH (Stay Safe), Regards, Patrice