Move objects to new layer(s) based upon color??

[mhupp]

So It seems Autocad uses all uppercase letters for paper and model space. Where BricsCAD only use the first letter uppercase. so when looking a the list with vl-remove it seems to be case sensitive.

 

"*PAPER_SPACE"  /=  "*Paper_Space" so it wasn't removing them.
 

This should remove them now and not get stuck in a loop.

(defun C:LayerColor (/ SS ent lay e blkname blklst entlst lst)
  (vl-load-com)
  (if (setq SS (ssget "_X" '((8 . "0") (-4 . "<NOT") (0 . "INSERT") (-4 . "NOT>") (410 . "Model"))))
    (foreach obj (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS)))
      (setq ent (vlax-ename->vla-object obj))
      (if (and (setq lay (itoa (vla-get-Color ent))) (= lay "256"))
        (setq lay (itoa (cdr (assoc 62 (tblsearch "layer" (vla-get-Layer ent))))))
      )
      (if (not (tblsearch "layer" lay))
        (entmake (list (cons 0 "LAYER")
                       (cons 100 "AcDbSymbolTableRecord")
                       (cons 100 "AcDbLayerTableRecord")
                       (cons 2 lay)
                       (cons 62 (atoi lay))
                       (cons 70 0)
                 )
        )
      )
      (vla-put-layer ent lay)
    )
  )
  (if (setq blklst (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))))
    (progn
      (vlax-for blk blklst (and (eq "AcDbBlockReference" (vla-get-ObjectName blk)))
        (setq lst (cons (vla-get-Name blk) lst))
      )
      (setq lst (vl-remove "*PAPER_SPACE" lst))
      (setq lst (vl-remove "*MODEL_SPACE" lst))
      (foreach blkname lst
        (setq ent (tblobjname "BLOCK" blkname))
        (while (setq ent (entnext ent))
          (setq entlst (cons ent entlst))
        )
        (foreach ent entlst
          (setq ent (vlax-ename->vla-object ent))
          (if (and (setq lay (itoa (vla-get-Color ent))) (= lay "256"))
            (setq lay (itoa (cdr (assoc 62 (tblsearch "layer" (vla-get-Layer ent))))))
          )
          (if (not (tblsearch "layer" lay))
            (entmake (list (cons 0 "LAYER")
                           (cons 100 "AcDbSymbolTableRecord")
                           (cons 100 "AcDbLayerTableRecord")
                           (cons 2 lay)
                           (cons 62 (atoi lay))
                           (cons 70 0)
                     )
            )
          )
          (vla-put-layer ent lay)
        )
      )
    )
  )
  (princ)
)

 

Edited March 18, 2022 by mhupp

[jim78b]

sorry my cursor freeze stuck.

[gp.triple]

in my lisp collection i have this, but not remember the original source for give credit

(defun c:color2layer (/ atts doc lay lays lokt)
(defun laycheck (ent color / lay)
(if (< 0 color 256)
(progn
(setq lay (vla-add lays (strcat "Color-" (itoa color))))
(vla-put-layer ent (vla-get-name lay))
(vla-put-color lay color)
(vla-put-color ent acbylayer)
)
)
)
(setq doc (vla-get-activedocument (vlax-get-acad-object))
lays (vla-get-layers doc)
)
(vlax-for lay lays
;;check for locked layers
(if (eq :vlax-true (vla-get-lock lay))
(progn
(setq lokt (cons (vla-get-name lay) lokt))
(vla-put-lock lay :vlax-false)
)
)
)
(vla-startundomark doc)
(vlax-for blk (vla-get-blocks doc)
(if (and (eq (vla-get-isxref blk) :vlax-false)
(not (vl-string-search "|" (vla-get-name blk)))
)
(progn
(vlax-for ent blk
(laycheck ent (vla-get-color ent))
(if (and (vlax-property-available-p ent "hasattributes")
(vla-get-hasattributes ent)
(setq atts (vlax-invoke ent "getattributes"))
)
(progn
(foreach att atts
(laycheck att (vla-get-color att))
(vla-update att)
)
)
)
)
)
)
)
(if lokt
;;reset locked layers
(foreach lay lokt
(vla-put-lock (vla-item lays lay) :vlax-true)
)
)
(vla-endundomark doc)
(princ "\nDone!")
(princ)
)

 

[jim78b]

thanks a lot works!! have a nice day