Select all layer turn to color 252

May 21

Hi to all,

I hope you can assist me in creating a Lisp routine that will systematically change all elements in the architectural layer within the drawing file to the XR layer and set their color to 252. This includes all entities such as blocks, text, etc.; everything must be moved to the XR layer.

The drawing should be purged afterward to remove any unused elements. The only exception to this change are the lighting fixtures, which the Lisp routine should prompt the user to specify.

I've attached the drawing file in AutoCAD 2018 format for your reference.

Thank you in advance for your assistance.

ArchiDwg.dwg

Edited May 22 by Mystogan

May 21

Try this:

I don't know which is your architectural layer, so the filer is for layer AM-5 - search for this in the LISP and change to suit.

For now blocks will be on layer XR but whatever is in the block will be as it is now (unchanged). Dimensions and leaders will be move to layer XR for colour over rides (line colours, arrow colours) will be as they are just now.

Command: text

(defun c:test ( / )

;;Sub Functions
;;Check layer exists or create layer
  (defun checklaystyle (LayDef / ) ; 1-6 in def LISP, 7 is transparency: Check or create layer
    (defun LM:setlayertransparency ( lay trn / ent )
      (defun LM:trans->dxf ( x )
        (logior (fix (* 2.55 (- 100 x))) 33554432)
      )
      (if (setq ent (tblobjname "layer" lay))
          (progn
              (regapp "accmtransparency")
              (entmod (append (entget ent) (list
                    (list -3
                      (list "accmtransparency"
                        (cons 1071 (LM:trans->dxf trn))
                      ) ; end list
                    ) ; end list
              ))) ; end entmod
          ) ; end progn
      ) ; end if
    ) ; end defun
    (setq Layname (nth 1 LayDef))
    (if ;;check for layer style
      (or (= NIL (tblsearch "layer" Layname))(/= (cdr (assoc 2 (tblsearch "layer" Layname))) 0.0) )
      (progn
        (setq style (entmakex (list
          '(000 . "LAYER")
          '(100 . "AcDbSymbolTableRecord")
          '(100 . "AcDbLayerTableRecord")
          (cons 002 (nth 1 LayDef)) ; layer name
          (cons 070 (atoi (nth 2 LayDef))) ; 
          (cons 062 (atoi (nth 3 LayDef))) ; colour
          (cons 006 (if (tblsearch "LTYPE" (nth 4 LayDef)) (nth 4 LayDef) "Continuous")) ; line type
          (cons 290 (atoi (nth 5 LayDef))) ; 
          (if (or (= (nth 6 LayDef) nil)(= (nth 6 LayDef) "")) ; plotting
            (cons 370 -3)
            (cons 370 (atoi (nth 6 LayDef)))
          )
        ))) ; end list, end entmake, end style
        (if (> (length layDef) 8)
          (LM:setlayertransparency Layname (atoi (nth 7 LayDef)) )
        )
      ) ;end progn
    ) ; end if
  )

;;Purge all
  (defun c:purgea( / endloop sel)
    (setq NoMutt_Old (getvar 'NoMutt))
    (repeat 3
      (setvar 'NoMutt 1)
      (command "-PURGE" "A" "*" "N")
      (command "-PURGE" "R" "*" "N") ;;Regapps
      (setvar 'NoMutt NoMutt_Old)
    )
    (princ "\nPurge All complete.")
    (princ)
  )
;; End sub functions


  (checklaystyle '("LAYER" "XR" "0" "0" "Continuous" "1" "-3" "0.0000") ) ;;layer Name flags Colour linetype plotting lineweight Transparency)
  (if (setq MySS (ssget "X" '((8 . "AM_5")))) ; select all on layer "AM_5"
    (progn

      (setq acount 0)
      (while (< acount (sslength MySS))       ; Loop through selection
        (setq MyEnt (ssname MySS acount))     ; Get each entity defition
        (setq ed (entget MyEnt))
        (setq ed (subst (cons 62 256) (assoc 62 ed) ed ))
        (setq ed (subst (cons 8 "XR") (assoc 8 ed) ed ))
        (entmod ed)                           ; Modify & update entity
        (setq acount (+ acount 1))
      ) ; end while
      (c:purgea)                              ; Purge all

  )) ; end if end progn
  (princ)
)

Edited May 21 by Steven P

May 21

9 minutes ago, Steven P said:

Try this:

I don't know which is your architectural layer, so the filer is for layer AM-5 - search for this in the LISP and change to suit.

For now blocks will be on layer XR but whatever is in the block will be as it is now (unchanged). Dimensions and leaders will be move to layer XR for colour over rides (line colours, arrow colours) will be as they are just now.

Command: text

(defun c:test ( / )

;;Sub Functions
;;Check layer exists or create layer
  (defun checklaystyle (LayDef / ) ; 1-6 in def LISP, 7 is transparency: Check or create layer
    (defun LM:setlayertransparency ( lay trn / ent )
      (defun LM:trans->dxf ( x )
        (logior (fix (* 2.55 (- 100 x))) 33554432)
      )
      (if (setq ent (tblobjname "layer" lay))
          (progn
              (regapp "accmtransparency")
              (entmod (append (entget ent) (list
                    (list -3
                      (list "accmtransparency"
                        (cons 1071 (LM:trans->dxf trn))
                      ) ; end list
                    ) ; end list
              ))) ; end entmod
          ) ; end progn
      ) ; end if
    ) ; end defun
    (setq Layname (nth 1 LayDef))
    (if ;;check for layer style
      (or (= NIL (tblsearch "layer" Layname))(/= (cdr (assoc 2 (tblsearch "layer" Layname))) 0.0) )
      (progn
        (setq style (entmakex (list
          '(000 . "LAYER")
          '(100 . "AcDbSymbolTableRecord")
          '(100 . "AcDbLayerTableRecord")
          (cons 002 (nth 1 LayDef)) ; layer name
          (cons 070 (atoi (nth 2 LayDef))) ; 
          (cons 062 (atoi (nth 3 LayDef))) ; colour
          (cons 006 (if (tblsearch "LTYPE" (nth 4 LayDef)) (nth 4 LayDef) "Continuous")) ; line type
          (cons 290 (atoi (nth 5 LayDef))) ; 
          (if (or (= (nth 6 LayDef) nil)(= (nth 6 LayDef) "")) ; plotting
            (cons 370 -3)
            (cons 370 (atoi (nth 6 LayDef)))
          )
        ))) ; end list, end entmake, end style
        (if (> (length layDef) 8)
          (LM:setlayertransparency Layname (atoi (nth 7 LayDef)) )
        )
      ) ;end progn
    ) ; end if
  )

;;Purge all
  (defun c:purgea( / endloop sel)
    (setq NoMutt_Old (getvar 'NoMutt))
    (repeat 3
      (setvar 'NoMutt 1)
      (command "-PURGE" "A" "*" "N")
      (command "-PURGE" "R" "*" "N") ;;Regapps
      (setvar 'NoMutt NoMutt_Old)
    )
    (princ "\nPurge All complete.")
    (princ)
  )
;; End sub functions


  (checklaystyle '("LAYER" "XR" "0" "0" "Continuous" "1" "-3" "0.0000") ) ;;layer Name flags Colour linetype plotting lineweight Transparency)
  (if (setq MySS (ssget "X" '((8 . "AM_5")))) ; select all on layer "AM_5"
    (progn

      (setq acount 0)
      (while (< acount (sslength MySS))       ; Loop through selection
        (setq MyEnt (ssname MySS acount))     ; Get each entity defition
        (setq ed (entget MyEnt))
        (setq ed (subst (cons 62 256) (assoc 62 ed) ed ))
        (setq ed (subst (cons 8 "XR") (assoc 8 ed) ed ))
        (entmod ed)                           ; Modify & update entity
        (setq acount (+ acount 1))
      ) ; end while
      (c:purgea)                              ; Purge all

  )) ; end if end progn
  (princ)
)

Hi steven

Thank you for the reply.

Actually all of them in the dwg are the architectural layer. The intent of lsp is routine change the layer even in the block(inside block) will turn into XR layer.

And the lsp will ask what are the block exempted for the XR layer which is the lighting fixtures. (user may select whay are those blocks)

Thank you, hope you still accomodate my inquiries.

May 22

To change the block elements you want to process the block definition. This way you only have to process 1 lighting block to "update" the other 300 lighting blocks in the drawing.

Untested so please use it on a copy or backup first. will output something like 50 - Blocks Processed (138) Enitiy's moved to XR layer

Also has a undo location so one undo rather then 100's

When I was working for an electrical contractor I would just burst everything and change it to color 255 and xref it into our electrical drawings.

(defun C:BurstAll (/ ss)
  (vl-load-com)
  (setq Drawing (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark Drawing)
  (while (setq ss (ssget "X" '((0 . "INSERT"))))
    (sssetfirst nil ss)
    (C:Burst)
  )
  (vla-endundomark Drawing)
  (vla-Regen Drawing acAllViewports)
  (princ)
)

XRBlocks.lsp

Edited May 22 by mhupp

May 22

Hi mhupp,

I believe we are in the same trade/discipline. Manually changing all the layers and block elements will undoubtedly take more time than usual, especially when the blocks and text are set to "By Layer," "By Block," or different colors.

The intent of this LSP is to have a single layer, which is XR. The only exemption to the layer change will be for lighting fixtures.

I hope someone can address my inquiries.

thank you

May 22

You have not said anything about "Lighting fixtures" what they are ?

It may be as simple as adding block names to this line of the code by Mhupp. I would do blocks 1st.

(not (member BlkName '("*Model_Space" "*Paper_Space" "Lighting fixture"))))

Using (command "chprop" ss where ss is a selection set of all objects and set layer to XR, maybe use turn on and thaw all layers, do block convert, then freeze the lighting fixtures layers before changing object layers. (setq ss (ssget "x"))

Yes have done similar for import from other software. Have code etc. But a lot of guessing.

May 22

Hi @BIGAL

In the attached file, the lighting fixtures are indicated in the Lighting Legend. However, to make this Lisp routine reusable, it would be more effective if the routine prompts the user to specify the lighting fixture blocks that should be excluded from being converted to the XR layer. This way, the routine can be adapted to different projects and requirements.

Thank you for your input. Unfortunately, the codes provided by @mhupp and @Steven P did not achieve the desired outcome, as they were unable to change all layers to the XR layer with a color of 252.

May 22

SETBYLAYER for all objects in the block BY LAYER.

then merge layers by LAYMRG

May 22

Hi @exceed

Thank you for noticing my post. How can I incorporate this functionality into the code?

May 22

.... nested blocks.....

I struggled last night to get something acceptable to process blocks and nested blocks. All would be good if there were no nested blocks, use (ssget "X" '((0 . "INSERT"))) as above and change them to bylayer / byblock. My preference would be to go by block and set the blocks to the required layer.

Have to go something like this I think

(setq MyBlock (cdr (assoc -2 (tblnext "Block" T))))
  (while MyBlock

... do stuff to MyBlock ..

  (setq MyBlock (cdr (assoc -2 (tblnext "Block"))))
)

Edit: Needs an attsync

(defun c:ALLBB ( / MyBlock MyEnt acount)   ;; ALL By-Block
  (setq MyBlock (tblnext "Block" T))       ;; Get first block definition
  (while MyBlock                           ;; Loop through block definitions
    (setq MyEnt (cdr (assoc -2 MyBlock)))  ;; Get first entity in block
    (while MyEnt                           ;; Loop through block entities
      (setq MyObj (vlax-ename->vla-object MyEnt)) ;;Convert to VLA- object name
      (vla-put-color MyObj 0)              ;; Set block entity colour to 'ByBlock'...be nice to use entmod for batch processing purposes
      (vla-put-layer MyObj "0")            ;; Set block entity layer to  '0'...be nice to use entmod for batch processing purposes
      (setq MyEnt (entnext MyEnt))         ;; next entity in block
    ) ; end while
    (setq MyBlock (tblnext "Block"))       ;; Next block
  ) ; end while
  (command "regen")                        ;;Regen drawing
  (princ "\nOK")                           ;; Report that all is OK
  (princ)
)

Edited May 22 by Steven P

May 22

Hi @Steven P

almost there, is it possible to incorporate you previous code to this new one?

May 22

Yes, I guess I could....

Try this:

This is changing all block contents to layer 0, and by block - better that way than setting the contents to say "XR" layer and colour 252

Creates layer 'XR' if necessary, this is hard coded into the routine for future reference and changes

Sets all objects in the space (model / paper) to NewColour, NewLayer (set here to be 'XR' and '252' - you'll see these variables in the code to change to suit)

Sets any entity true colour to colour index colour '252'

Sets the current layer to 0 which helps with

Purge 3 times to make sure

There are still colours shown and might not work as fully as expected:

Any mtext with a colour override or layer over ride will retain that. Look for the lisp 'Strip Mtext' to do this

Dimensions and leader colours are not modified. There are LISPs out there that will do this too

I haven't included to exclude user selected fittings - light fittings.

Edit...

Removed VLA- lines

(defun c:test ( / NewColour NewLayer MySS acount MyEnt ed)

;;Sub Functions
  (defun checklaystyle (LayDef / LayName Style )             ;;Check layer exists or create layer
;; 1-6 in def LISP, 7 is transparency: Check or create layer:-
;; "Layer", Name, flags, Colour, linetype, plotting, lineweight, Transparency
    (defun LM:setlayertransparency ( lay trn / ent )         ;;Ref Lee Mac
      (defun LM:trans->dxf ( x )
        (logior (fix (* 2.55 (- 100 x))) 33554432)
      )
      (if (setq ent (tblobjname "layer" lay))
          (progn
              (regapp "accmtransparency")
              (entmod (append (entget ent) (list
                    (list -3
                      (list "accmtransparency"
                        (cons 1071 (LM:trans->dxf trn))
                      ) ; end list
                    ) ; end list
              ))) ; end entmod
          ) ; end progn
      ) ; end if
    ) ; end defun

    (setq Layname (nth 1 LayDef))
    (if                                           ;;check if layer exists in drawing
      (or (= NIL (tblsearch "layer" Layname))(/= (cdr (assoc 2 (tblsearch "layer" Layname))) 0.0) )
      (progn                                      ;;If not entmake it
        (setq style (entmakex (list
          '(000 . "LAYER")
          '(100 . "AcDbSymbolTableRecord")
          '(100 . "AcDbLayerTableRecord")
          (cons 002 (nth 1 LayDef)) ; layer name
          (cons 070 (atoi (nth 2 LayDef))) ; 
          (cons 062 (atoi (nth 3 LayDef))) ; colour
          (cons 006 (if (tblsearch "LTYPE" (nth 4 LayDef)) (nth 4 LayDef) "Continuous")) ; line type
          (cons 290 (atoi (nth 5 LayDef))) ; 
          (if (or (= (nth 6 LayDef) nil)(= (nth 6 LayDef) "")) ; plotting
            (cons 370 -3)
            (cons 370 (atoi (nth 6 LayDef)))
          )
        ))) ; end list, end entmake, end style
        (if (> (length layDef) 8)                ;;Set layer transparency
          (LM:setlayertransparency Layname (atoi (nth 7 LayDef)) )
        )
      ) ;end progn
    ) ; end if
  )

  (defun ALLBB ( / MyBlock MyEnt MySS ed acount)    ;;Set all entities in all blocks to ByBlock, layer 0
    (setq MyBlock (tblnext "Block" T))           ;; Get first block definition
    (while MyBlock                               ;; Loop through block definitions
      (setq MyEnt (cdr (assoc -2 MyBlock)))      ;; Get first entity in block
      (while MyEnt                               ;; Loop through block entities
        (setq ed (entget MyEnt))
        (setq ed (append ed '((62 . 0))))        ;; Add ByBlock colour if it doesn't have colour set
        (setq ed (subst (cons 62 0) (assoc 420 ed) ed )) ;; Remove true colour
        (setq ed (subst (cons 62 0) (assoc 62 ed) ed ))  ;; Modify Colour index
        (setq ed (subst (cons 8 "0") (assoc 8 ed) ed ))  ;; Layer
        (entmod ed)
        (setq MyEnt (entnext MyEnt))             ;; next entity in block
      ) ; end while
      (setq MyBlock (tblnext "Block"))           ;; Next block
    ) ; end while
    (command "regen")
;;https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/is-there-a-lisp-to-run-battman-or-attsync-for-all-blocks-in-a/td-p/10847443
    (if (ssget "_X" '((0 . "INSERT")(66 . 1)))
      (command "_.attsync" "Name" "*")
    )
  )

  (defun c:purgea( / endloop sel)               ;; Purge all
    (setq NoMutt_Old (getvar 'NoMutt))
    (repeat 3                                   ;; Do it 3 times to be sure
      (setvar 'NoMutt 1)
      (command "-PURGE" "A" "*" "N")            ;; 'All'
      (command "-PURGE" "R" "*" "N")            ;; Regapps
      (setvar 'NoMutt NoMutt_Old)
    )
  )
;; End sub functions

  (setq NewColour 252)                        ;; Colour
  (setq NewLayer "XR")                        ;; Layer
  (checklaystyle (list "LAYER" NewLayer "0" "0" "Continuous" "1" "-3" "0.0000") ) ;; To Check new layer exists
  (ALLBB)                                     ;; Set all block entities to layer 0, colour 0
  (if (setq MySS (ssget "X"))                 ;; select all
    (progn
      (setq acount 0)
      (while (< acount (sslength MySS))       ;; Loop through selection
        (setq MyEnt (ssname MySS acount))     ;; Get each entity defition
        (setq ed (entget MyEnt))
        (if (= (assoc 62 ed) nil)             ;; Colour index
          (setq ed (append ed '((62 . 1))))
        ) ; end if
        (setq ed (subst (cons 62 NewColour) (assoc 420 ed) ed )) ;; Remove true colour
        (setq ed (subst (cons 62 NewColour) (assoc 62 ed) ed ))  ;; Modify Colour index
        (setq ed (subst (cons 8 NewLayer) (assoc 8 ed) ed ))     ;; Layer
        (entmod ed)                           ;; Modify & update entity
        (setq acount (+ acount 1))
      ) ; end while
      (setvar 'clayer "0")                    ;; Active layer '0'
      (c:purgea)                              ;; Purge all

  )) ; end if end progn
  (princ)
)

Edited May 22 by Steven P

May 22

Hi @Steven P

thank you for accepting my post, I will study your code. It is really challenging those text and lighting legend

again thank you very much

May 22

For info, this one should remove simple colour codes from mtext:

Fails if the actual mtext text contains a colour code string '\C#;' where # is any number

Does not determine if # is a valid colour number, 0 - 256, strips the code out

Will only work for the first 256 characters of an mtext string

(defun c:NoColMT ( / ) ; No Colour MText
  (NoForMT "C")  ;;Run NoForMT for 'C' colour codes. C in uppercase. Also: T, H, W, Q
  (princ)
)
(defun NoForMt ( MyCode / MyEnt ed MyString SwapSlashes StrPos ColonPos ColourCode) ; C, T, H, W, Q
  (setq MyEnt (car (entsel)))        ;;Select single text entity
  (setq ed (entget MyEnt))           ;;Entity Definition
  (setq MyString (cdr (assoc 1 ed))) ;;Extract Text
  (setq SwapSlashes "ADDINGINBLACKSLASH")

  (while (wcmatch MyString "*\\\\*" )(setq MyString (vl-string-subst SwapSlashes "\\\\" MyString) ))

  (if (and (wcmatch MyString (strcat "*{*`\\" MyCode "*}*")) (= (cdr (assoc 0 ed)) "MTEXT") ) ;;If selected entity contains 'MyCode' and is MText
    (progn
      (while (wcmatch MyString (strcat "*{*`\\" MyCode "*}*"))
        (setq StrPos (vl-string-search (strcat "\\" MyCode) MyString ) )
        (setq ColonPos (+ (vl-string-search ";" MyString (+ StrPos 3)) 2))
        (setq ColourCode (substr MyString (+ StrPos 1) (- ColonPos (+ StrPos 1)) ) )
        (setq MyString (vl-string-subst "" ColourCode MyString) )
      ) ; end while

      (while (wcmatch MyString (strcat "*" SwapSlashes "*") )(setq MyString (vl-string-subst "\\\\" SwapSlashes MyString) ))

      (setq ed (subst (cons 1 MyString) (assoc 1 ed) ed ))     ;; text String <~250 characters
      (entmod ed)                           ;; Modify & update entity
    ) ; end progn
  ) ; end if
)

Edited May 24 by Steven P
EDIT: Didn't quite work right for vary rare case of for example the text containing '\C1;'

May 22

And this adds it into the above:

Note: Some text in the example drawing is surrounded by hatching, it might be better to colour all text black or a different shade of grey for visibility reasons.

(defun c:test ( / NewColour NewLayer MySS acount MyEnt ed)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Sub Functions
  (defun checklaystyle (LayDef / LayName Style )             ;;Check layer exists or create layer
;; 1-6 in def LISP, 7 is transparency: Check or create layer:-
;; "Layer", Name, flags, Colour, linetype, plotting, lineweight, Transparency
    (defun LM:setlayertransparency ( lay trn / ent )         ;;Ref Lee Mac
      (defun LM:trans->dxf ( x )
        (logior (fix (* 2.55 (- 100 x))) 33554432)
      )
      (if (setq ent (tblobjname "layer" lay))
          (progn
              (regapp "accmtransparency")
              (entmod (append (entget ent) (list
                    (list -3
                      (list "accmtransparency"
                        (cons 1071 (LM:trans->dxf trn))
                      ) ; end list
                    ) ; end list
              ))) ; end entmod
          ) ; end progn
      ) ; end if
    ) ; end defun

    (setq Layname (nth 1 LayDef))
    (if                                           ;;check if layer exists in drawing
      (or (= NIL (tblsearch "layer" Layname))(/= (cdr (assoc 2 (tblsearch "layer" Layname))) 0.0) )
      (progn                                      ;;If not entmake it
        (setq style (entmakex (list
          '(000 . "LAYER")
          '(100 . "AcDbSymbolTableRecord")
          '(100 . "AcDbLayerTableRecord")
          (cons 002 (nth 1 LayDef)) ; layer name
          (cons 070 (atoi (nth 2 LayDef))) ; 
          (cons 062 (atoi (nth 3 LayDef))) ; colour
          (cons 006 (if (tblsearch "LTYPE" (nth 4 LayDef)) (nth 4 LayDef) "Continuous")) ; line type
          (cons 290 (atoi (nth 5 LayDef))) ; 
          (if (or (= (nth 6 LayDef) nil)(= (nth 6 LayDef) "")) ; plotting
            (cons 370 -3)
            (cons 370 (atoi (nth 6 LayDef)))
          )
        ))) ; end list, end entmake, end style
        (if (> (length layDef) 8)                ;;Set layer transparency
          (LM:setlayertransparency Layname (atoi (nth 7 LayDef)) )
        )
      ) ;end progn
    ) ; end if
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun ALLBB ( / MyBlock MyEnt MySS ed acount)    ;;Set all entities in all blocks to ByBlock, layer 0
    (setq MyBlock (tblnext "Block" T))           ;; Get first block definition
    (while MyBlock                               ;; Loop through block definitions
      (setq MyEnt (cdr (assoc -2 MyBlock)))      ;; Get first entity in block
      (while MyEnt                               ;; Loop through block entities
        (setq ed (entget MyEnt))
        (setq ed (append ed '((62 . 0))))        ;; Add ByBlock colour if it doesn't have colour set
        (setq ed (subst (cons 62 0) (assoc 420 ed) ed )) ;; Remove true colour
        (setq ed (subst (cons 62 0) (assoc 62 ed) ed ))  ;; Modify Colour index
        (setq ed (subst (cons 8 "0") (assoc 8 ed) ed ))  ;; Layer
        (if (= (cdr (assoc 0 ed)) "MTEXT") (setq ed (MTextCol ed)))
        (entmod ed)
        (setq MyEnt (entnext MyEnt))             ;; next entity in block
      ) ; end while
      (setq MyBlock (tblnext "Block"))           ;; Next block
    ) ; end while
    (command "regen")
;;https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/is-there-a-lisp-to-run-battman-or-attsync-for-all-blocks-in-a/td-p/10847443
    (if (ssget "_X" '((0 . "INSERT")(66 . 1)))
      (command "_.attsync" "Name" "*")
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun MTextCol ( ed / MyString StrPos ColonPos ColourCode) ;;Re-sets mtext override colours
    (setq MyString (cdr (assoc 1 ed)))
    (if (or 
        (wcmatch (strcase MyString) "*`\C*;*")
        (wcmatch (strcase MyString) "*`\\C*;*")
      ) ; endor
      (progn
        (while (wcmatch (strcase MyString) "*`\\C*;*")
          (setq StrPos (vl-string-search "\\C" (strcase MyString) ) )
          (setq ColonPos (+ (vl-string-search ";" MyString (+ StrPos 3)) 2))
          (setq ColourCode (substr MyString (+ StrPos 1) (- ColonPos (+ StrPos 1)) ) )
          (setq MyString (vl-string-subst "" ColourCode MyString) )
        ) ; end while
        (setq ed (subst (cons 1 MyString) (assoc 1 ed) ed ))     ;; text String <~250 characters
      ) ; end progn
    ) ; end if
    ed
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun c:purgea( / endloop sel)             ;; Purge all
    (setq NoMutt_Old (getvar 'NoMutt))
    (setvar 'NoMutt 1)
    (command "-PURGE" "A" "*" "N")            ;; 'All'
    (setvar 'NoMutt NoMutt_Old)
  )
;; End sub functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (setq NewColour 252)                        ;; Colour
  (setq NewLayer "XR")                        ;; Layer
  (c:purgea)                                  ;; Initial Purge all
  (checklaystyle (list "LAYER" NewLayer "0" "0" "Continuous" "1" "-3" "0.0000") ) ;; To Check new layer exists
  (ALLBB)                                     ;; Set all block entities to layer 0, colour 0
  (if (setq MySS (ssget "X"))                 ;; select all
    (progn
      (setq acount 0)
      (while (< acount (sslength MySS))       ;; Loop through selection
        (setq MyEnt (ssname MySS acount))     ;; Get each entity defition
        (setq ed (entget MyEnt))
        (if (= (assoc 62 ed) nil)             ;; Colour index
          (setq ed (append ed '((62 . 1))))
        ) ; end if
        (setq ed (subst (cons 62 NewColour) (assoc 420 ed) ed ))  ;; Remove true colour
        (setq ed (subst (cons 62 NewColour) (assoc 62  ed) ed ))  ;; Modify Colour index
        (setq ed (subst (cons 8  NewLayer)  (assoc 8   ed) ed ))  ;; Layer
        (if (= (cdr (assoc 0 ed)) "MTEXT") (setq ed (MTextCol ed)))
        (entmod ed)                           ;; Modify & update entity
        (setq acount (+ acount 1))
     ) ; end while
      (setvar 'clayer "0")                    ;; Active layer '0'
  )) ; end if end progn

  (c:purgea)                                  ;; Purge all
  (c:purgea)                                  ;; Purge all, 2x to be sure
  (princ)
)

May 23

Hi @Steven P

thank you very much for the additional info, will work out this code

again, thank you

May 24

lets see what ChatGPT says

Quote

This AutoLISP code defines a function c:test that purges all unnecessary items, ensures the existence

of a specified layer, sets all block entities to default properties, and changes the color and layer of all

entities in the drawing. Here is a breakdown of the code:

Main Function: c:test

Set Initial Variables:

NewColour: The color index to be applied to entities (252).

NewLayer: The layer name to be applied to entities ("XR").

Purge All Entities:

Calls c:purgea to remove all unreferenced items from the drawing.

Check or Create Layer:

Calls checklaystyle with layer details to ensure the layer exists or create it if not.

Set All Block Entities to Default Properties:

Calls ALLBB to set all entities in all blocks to use layer 0 and color ByBlock.

Change Color and Layer of All Entities:

Uses ssget "X" to select all entities in the drawing.

Loops through each selected entity to:

Modify its color to NewColour.

Modify its layer to NewLayer.

Adjust MTEXT color if needed using MTextCol.

Sets the active layer to "0".

Purge Again:

Calls c:purgea twice to ensure all unreferenced items are removed.

Sub Functions

checklaystyle: Checks if a layer exists, and if not, creates it with specified properties including transparency.

ALLBB: Loops through all block definitions and sets entities within each block to layer 0 and color ByBlock.

MTextCol: Removes color overrides from MTEXT entities.

c:purgea: Purges all unreferenced items from the drawing.

To use this function:

Load the LISP code in AutoCAD.

Run the test command by typing c:test in the command line.

This script helps to standardize the appearance of entities in a drawing by ensuring

they all adhere to specified layer and color settings, while also cleaning up the

drawing to remove unnecessary items.

Sign In

Select all layer turn to color 252

Recommended Posts

Mystogan

Steven P

Mystogan

mhupp

Mystogan

BIGAL

Mystogan

exceed

Mystogan

Steven P

Mystogan

Steven P

Mystogan

Steven P

Steven P

Mystogan

mhupp

Join the conversation

Tutorials

Forums

Activity