Lisp to New layer with block name

[gastom8]

Hello Forum, I wanted to know if you can help me with a job.

I need that when selecting a set of entities, each block is moved to a new layer. Now the name of the new layer should be “the name of the original block layer” + ”_” + “block name”.

Additionally, the new layer (to which the block is moved) must have the same attributes (color, line type,...) as the block's original layer.

Searching I found a LISP that does that task but in part, they only move the block to a new layer with the name of the block. But the name of the new layer does not have the name of the original layer and the new layer has the attributes of the original layer.

Link to the partial solutions I found:

https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/new-layer-with-block-name/td-p/10070...

https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-to-move-blocks-to-their-own-lay...

https://forums.augi.com/showthread.php?172561-Create-layer-from-block-name-and-move-blocks-to-the-ne...

I was modifying and working on the solutions I found but I couldn't get it to work.

Can somebody help me?

Sorry for my English.

[ec-cad]

Try this one. Seems to work as you wanted on limited testing.

Cheers

ECCAD

;; Move_Block_to_New_Layer.lsp
;;
  (defun C:MBNL () ; 'Move_'Block_to_'New_'Layer
   (setq clay (getvar "clayer")); reset on end
;;
;; Define DXF function
;;
 (defun dxf (code elist)
  (cdr (assoc code elist))
 ); end function dxf

;;
;; Define function tdlist
;;
 (defun tdlist (tbname / tdata)
  (while (setq tdata (tblnext tbname (not tdata)))
   (setq tblist (append tblist (list tdata)))
  ); end while
 ); end function tdlist
;; 
;; make layer list for this file...
;;
(defun LL ()
 (setq tblist nil)
 (foreach tbdata (tdlist "layer")
  (setq lname (dxf 2 tbdata))
  (if (/= (strcase lname) "DEFPOINTS")
   (progn
     (if (not (member lname lay_lst))
      (setq lay_lst (cons lname lay_lst))
     ); end if
   ); end progn
  ); end if
 ); end foreach
); end function LL
;;
;; Function to grab an item 'name' from a collection
  (defun layexist (collection item / rslt)
   (if
     (not
       (vl-catch-all-error-p 
         (setq rslt
           (vl-catch-all-apply 'vla-item
             (list collection item)
           );trap error
         );end setq
       );return T if successful, else nil
     );end not
     rslt; return object or nil
   );end if
  );end defun
;;
;; Function to obtain Layer Status for Layer Chosen
 (defun get_layer_status ( layer / ado lyo lay )
  (setq ado (vla-get-ActiveDocument (vlax-get-acad-object)));get pointer to activeDocument
  (setq lyo (vla-get-layers ado))
  (if layer
   (progn
    (setq lay (layexist lyo layer))
    (if lay
     (progn
;; Layer Name only - already Know that..
      (setq lnam (vla-get-Name lay));                         0
;; Stats: ON, Frozen, Locked, Plot, Color, LineType, LineWeight, Description
      (setq Lon (vla-get-LayerOn lay));                          :vlax-true ..-1
      (setq Frz (vla-get-Freeze lay));                            0
      (setq Locked (vla-get-Lock lay));                           0
      (setq Plotme (vla-get-Plottable lay)) ; :vlax-true ..       -1
      (setq PlotStyNam (vla-get-PlotStyleName lay));             "Color_7"
      (setq TruCol (vla-get-TrueColor lay)); returns IAcadAcCmColor as Object
      (setq Col (vla-get-ColorIndex TruCol));                     7 (white)
      (setq Lty (vla-get-Linetype lay)) ;                         CONTINUOUS
      (setq Lwt (vla-get-Lineweight lay));                       -3 (Default ??)
      (setq desc (vla-get-Description lay));                      "" or Description
     ); progn
    ); if
   ); progn
  ); if
  (if ado (vlax-release-object ado))
  (if lyo (vlax-release-object lyo))
  (if lay (vlax-release-object lay))
  (princ)
 ); end function get_layer_status

;; *************** MAIN ****************
(LL) ; Get Existing Layer List - Returns lay_lst

 (princ "\n")
 (princ "\nPick your Blocks:")
 (setq ss (ssget "_:L" '((0 . "INSERT"))))
  (if ss
   (progn
    (setq N 0 bn_lst (list))
;; make list of blocknames
    (repeat (sslength ss)
     (setq elist (entget (ssname ss N)))
     (setq bn (cdr (assoc 2 elist)))
      (if bn
       (progn
        (if (not (member bn bn_lst))
         (setq bn_lst (cons bn bn_lst))
        ); if
       ); progn
      ); if
      (setq N (+ N 1))
     ); repeat
;; foreach blockname in bn_lst, make Layer, set Layer Properties.
    (setq N 0)
    (repeat (length bn_lst)
     (setq ss1 nil)
     (setq blkname (nth N bn_lst))
     (setq ss1 (ssget "X" (list (cons 2 blkname)(cons 0 "INSERT"))))
      (if ss1
       (progn
        (setq NN 0)
        (repeat (sslength ss1)
         (setq elist (entget (ssname ss1 NN)))
         (setq olay (cdr (assoc 8 elist)))
         (get_layer_status olay)
         (setq nlayname (strcat olay "_" blkname))
         (command "_layer" "M" nlayname ""); if existing, ignored
          (if (not (member nlayname lay_lst))
          (progn
           (command "_layer" "C" Col nlayname "")
           (command "_layer" "LT" Lty nlayname "")
; add others as needed
           (LL); refresh Layers Object Table
           (get_layer_status olay)
           (setq lay_lst (cons nlayname lay_lst)); and add it to the list
          ); progn
         ); if
         (if (ssname ss1 NN)
          (command "_change" (ssname ss1 NN) "" "P" "LA" nlayname "")
         ); if
        (setq NN (+ NN 1))
       ); repeat
      ); progn
     ); if
     (setq N (+ N 1))
    ); repeat
   ); progn
  ); if ss
 (setvar "clayer" clay); reset
 (princ)
); Function MBNL
 (princ "\n")
 (princ "\nType MBNL to run:")
 (princ); silent load

[Kent1Cooper]

Are any of the Blocks ever dynamic?

[Kent1Cooper · Accepted solution]

---

@gastom8 wrote:

... when selecting a set of entities, each block is moved to a new layer. Now the name of the new layer should be “the name of the original block layer” + ”_” + “block name”. .... must have the same attributes (color, line type,...) as the block's original layer. ....

---

If I understand correctly, it seems to me this can be quite a bit simpler.  Limited testing:

(defun C:BNLBN ; = Block(s) to New Layer with Block Name
  (/ ss n blkobj name lay newlay)
  (if (setq ss (ssget "_:L" '((0 . "INSERT"))))
    (repeat (setq n (sslength ss)); then
      (setq
        blkobj (vlax-ename->vla-object (ssname ss (setq n (1- n))))
        name (vla-get-EffectiveName blkobj)
        lay (vla-get-Layer blkobj)
        newlay (strcat lay "_" name)
      ); setq
      (if (not (tblsearch "layer" newlay))
        (entmake (append (entget (tblobjname "layer" lay)) (list (cons 2 newlay))))
        ;; create new Layer of same properties as Block's with expanded name
      ); if
      (vla-put-Layer blkobj newlay)
    ); repeat
    (prompt "\nNo Block(s) on unlocked Layer(s) selected.")
  ); if
  (prin1)
)

Some possible improvements, if desired:

If you use an old-enough version that dynamic Blocks are not in the picture, so a Block insertion doesn't have an 'effectivename' Property, it can be adjusted to allow for that as well as accounting for possible dynamic Blocks in newer versions.

It does the same with XREFs as it does with regular Blocks.  If you don't want that, it could be made to leave XREFs alone.  [Same with Windows Metafiles and very-old-version Hatch patterns, which are also "INSERT" objects.]

And the usual -- *error* handling, Undo begin/end wrapping, etc.

[komondormrex]

---

@Kent1Cooper wrote:

---

that won't duplicate layer's transparency, this will

(entmake (subst (cons 2 newlay) (cons 2 lay) (entget (tblobjname "layer" lay) '("*"))))

[ec-cad]

Kent,

Your's works a treat with patch on Message 5, and considers effective names as well.

I guess after 40 years, seems we all can learn something new.

Doesn't touch anything on Frozen Layers. (which it shouldn't)

ECCAD

😃

[gastom8]

Hello.

The first and most important thing is to apologize for taking so long to respond.
I had a personal problem with a family member and I did not have access to a computer with AutoCAD.

The second thing is to thank you for the solutions.

I was just able to verify and both options work well, they do exactly what I needed.

P.S. I apologize again for the delay in responding.