All blocks to be set to ByLayer (color and linetype)

[baker]

I searched and did not really find the results i was looking for.

I am looking for a Lisp that when called, will change every block in the DWG to ByLayer color and line type.

I have one i found recently that works, but you have to select each block.

this is the Lisp i found..

    ;   File Name: FIXBLOCK.LSP
    ;   Description: Puts all of a blocks sub-entities on layer 0 with color and
    ;					  linetype set to BYBLOCK. The block, itself, will remain on
    ;					  its' original layer.
    ;
    ;*******************************************************************************


(defun d_FixBlock (/             eBlockSel ; Block selection
                   lInsertData ; Entity data
                   sBlockName ; Block name
                   lBlockData ; Entity data
                   eSubEntity ; Sub-entity name
                   lSubData ; Sub-entity data
                   iCount ; Counter
                  )

  ;; Redefine error handler

  (setq
    d_#error *error*
    *error*  d_FB_Error
  ) ;_ end setq

  ;; Set up environment

  (setq #SYSVARS (#SaveSysVars (list "cmdecho")))

  (setvar "cmdecho" 0)
  (command "._undo" "_group")

  ;; Get block from user and make sure it's an INSERT type

  (if (setq eBlockSel (entsel "\nSelect block to change :"))
    (progn
      (if (setq lInsertData (entget (car eBlockSel)))
        (if (= (cdr (assoc 0 lInsertData)) "INSERT")
          (setq sBlockName (cdr (assoc 2 lInsertData)))
          (progn
            (alert "Entity selected is not a block!")
            (exit)
          ) ;_ end progn
        ) ;_ end if
        (progn
          (alert "Invalid Block Selection!")
          (exit)
        ) ;_ end progn
      ) ;_ end if

      ;; Get block info from the block table

      (setq
        lBlockData (tblsearch "BLOCK" sBlockName)
        eSubEntity (cdr (assoc -2 lBlockData))
      ) ;_ end setq

      ;; Make sure block is not an Xref

      (if (not (assoc 1 lBlockData))
        (progn
          (princ "\nProcessing block: ")
          (princ sBlockName)

          (princ "\nUpdating blocks sub-entities. . .")

          ;; Parse through all of the blocks sub-entities

          (while eSubEntity

            (princ " .")
            (setq lSubData (entget eSubEntity))

            ;; Update layer property

            (if (assoc 8 lSubData)
              (progn
                (setq lSubData
                       (subst
                         (cons 8 "0")
                         (assoc 8 lSubData)
                         lSubData
                       ) ;_ end subst
                ) ;_ end setq
                (entmod lSubData)
              ) ;_ end progn
            ) ;_ end if

            ;; Update the linetype property

            (if (assoc 6 lSubData)
              (progn
                (setq lSubData
                       (subst
                         (cons 6 "BYBLOCK")
                         (assoc 6 lSubData)
                         lSubData
                       ) ;_ end subst
                ) ;_ end setq
                (entmod lSubData)
              ) ;_ end progn
              (entmod (append lSubData (list (cons 6 "BYBLOCK"))))
            ) ;_ end if

            ;; Update the color property

            (if (assoc 62 lSubData)
              (progn
                (setq lSubData
                       (subst
                         (cons 62 0)
                         (assoc 62 lSubData)
                         lSubData
                       ) ;_ end subst
                ) ;_ end setq
                (entmod lSubData)
              ) ;_ end progn
              (entmod (append lSubData (list (cons 62 0))))
            ) ;_ end if

            (setq eSubEntity (entnext eSubEntity))
    ; get next sub entity

          ) ; end while

          ;; Update attributes

          (idc_FB_UpdAttribs)

        ) ; end progn
        (alert "XREF selected. Not updated!")
      ) ; end if
    ) ; end progn
    (alert "Nothing selected.")
  ) ; end if

;;; Pop error stack and reset environment

  (idc_RestoreSysVars)

  (princ "\nDone!")

  (setq *error* d_#error)

  (princ)

)   ; end defun

    ;*******************************************************************************
    ; Function to update block attributes
    ;*******************************************************************************
(defun idc_FB_UpdAttribs ()

  ;; Update any attribute definitions

  (setq iCount 0)

  (princ "\nUpdating attributes. . .")
  (if (setq ssInserts (ssget "x"
                             (list (cons 0 "INSERT")
                                   (cons 66 1)
                                   (cons 2 sBlockName)
                             ) ;_ end list
                      ) ;_ end ssget
      ) ;_ end setq
    (repeat (sslength ssInserts)

      (setq eBlockName (ssname ssInserts iCount))

      (if (setq eSubEntity (entnext eBlockName))
        (setq
          lSubData (entget eSubEntity)
          eSubType (cdr (assoc 0 lSubData))
        ) ;_ end setq
      ) ;_ end if

      (while (or (= eSubType "ATTRIB") (= eSubType "SEQEND"))

        ;; Update layer property

        (if (assoc 8 lSubData)
          (progn
            (setq lSubData
                   (subst
                     (cons 8 "0")
                     (assoc 8 lSubData)
                     lSubData
                   ) ;_ end subst
            ) ;_ end setq
            (entmod lSubData)
          ) ;_ end progn
        ) ;_ end if

        ;; Update the linetype property

        (if (assoc 6 lSubData)
          (progn
            (setq lSubData
                   (subst
                     (cons 6 "BYBLOCK")
                     (assoc 6 lSubData)
                     lSubData
                   ) ;_ end subst
            ) ;_ end setq
            (entmod lSubData)
          ) ;_ end progn
          (entmod (append lSubData (list (cons 6 "BYBLOCK"))))
        ) ;_ end if

        ;; Update the color property

        (if (assoc 62 lSubData)
          (progn
            (setq lSubData
                   (subst
                     (cons 62 0)
                     (assoc 62 lSubData)
                     lSubData
                   ) ;_ end subst
            ) ;_ end setq
            (entmod lSubData)
          ) ;_ end progn
          (entmod (append lSubData (list (cons 62 0))))
        ) ;_ end if

        (if (setq eSubEntity (entnext eSubEntity))
          (setq
            lSubData (entget eSubEntity)
            eSubType (cdr (assoc 0 lSubData))
          ) ;_ end setq
          (setq eSubType nil)
        ) ;_ end if

      ) ; end while

      (setq iCount (1+ iCount))

    ) ; end repeat

  ) ; end if
  (command "regen")
)   ; end defun

    ;*******************************************************************************
    ; Function to save a list of system variables
    ;*******************************************************************************
(defun #SaveSysVars (lVarList / sSystemVar)
  (mapcar
    '(lambda (sSystemVar)
       (setq lSystemVars
              (append lSystemVars
                      (list (list sSystemVar (getvar sSystemVar)))
              ) ;_ end append
       ) ;_ end setq
     ) ;_ end lambda
    lVarList
  ) ;_ end mapcar

  lSystemVars

) ;_ end defun
    ;*******************************************************************************
    ; Function to restore a list of system variables
    ;*******************************************************************************
(defun idc_RestoreSysVars ()
  (mapcar
    '(lambda (sSystemVar)
       (setvar (car sSystemVar) (cadr sSystemVar))
     ) ;_ end lambda
    #SYSVARS
  ) ;_ end mapcar
) ;_ end defun
    ;*******************************************************************************
    ; Error Handler
    ;*******************************************************************************
(defun d_FB_Error (msg)

  (princ "\nError occurred in the Fix Block routine...")
  (princ "\nError: ")
  (princ msg)

  (setq *error* d_#error)
  (if *error*
    (*error* msg)
  ) ;_ end if

  (command)

  (if (/= msg "quit / exit abort")
    (progn
      (command "._undo" "_end")
      (command "._u")
    ) ;_ end progn
  ) ;_ end if

  (idc_RestoreSysVars)

  (princ)

) ;_ end defun
    ;*******************************************************************************

(defun FB () (d_FixBlock))

(fb)
(princ)

also, i cannot get this lisp to work without apploading each time i need it.

[BlackBox]

Why not just use the SETBYLAYER command?

[baker]

Why not just use the SETBYLAYER command?

because i forgot about that command.. lol.

[BlackBox]

because i forgot about that command.. lol.

lmfao

... Happy to help!

[Tharwat]

because i forgot about that command.. lol.

Me too , every time Renderman reminds me of it by his precious words and I keep on forgetting it .

My routine is ready to delivery but this command hold my energy LOL....

[David Bethel]

I honestly don't know much about setbyblock, but this should give a bit of flexibility as well

(defun c:blk2def (/ bl tdef fe fd)

;;;GROUP LIST Group_Number Sysvar_Name New_Value

  (setq bl '(( 8 "CLAYER"      "0")
             ( 6 "CELTYPE"     "BYLAYER")
             (39 "THICKNESS"    0.0)
             (48 "CELTSCALE"    1)
             (62 "CECOLOR"      256)))

  (while (setq tdef (tblnext "BLOCK" (not tdef)))
         (setq fe (cdr (assoc -2 tdef)))
         (princ (strcat "\n" (cdr (assoc 2 tdef))))
         (entmake tdef)
         (while fe
           (setq fd (entget fe))
           (foreach g bl
              (cond ((not (getvar (nth 1 g))))
                    ((assoc (nth 0 g) fd)
                     (setq fd (subst (cons (nth 0 g) (nth 2 g))
                                     (assoc (nth 0 g) fd) fd)))
                    (T
                     (setq fd (append fd (list (cons (nth 0 g) (nth 2 g))))))))
           (entmake fd)
           (setq fe (entnext fe)))
         (entmake (list (cons 0 "ENDBLK")(cons 8 "0"))))

  (command "_.REGENALL")
  (prin1))

You can manipulate the list bl to your needs.

• SNVALID Layer Name
• Linetypes must exist prior to calling this for it work properly.
• Colors 0-256

It does not address existing ATTRIButes.


-David

[baker]

ahhhh... now i remember.. i want the linework in the blocks to move to layer 0 as well as bylayer for everything else..

[Lee Mac]

Give this a try:

(defun c:test ( / acdoc )

    ;;-----------------------------------------------------------
    ;; All block objects to Layer "0", Color/Linetype ByLayer
    ;; Lee Mac 2011  -  www.lee-mac.com
    ;;-----------------------------------------------------------
  
    (vlax-for block
        (vla-get-blocks
            (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))
        )
        (if
            (and
                (eq :vlax-false (vla-get-islayout block))
                (eq :vlax-false (vla-get-isxref block))
            )
            (vlax-for object block
                (mapcar
                    (function
                        (lambda ( property value )
                            (vl-catch-all-apply 'vlax-put-property (list object property value))
                        )
                    )
                   '(layer color linetype)
                    (list "0" acbylayer "BYLAYER")
                )
            )
        )
    )
    (vla-regen acdoc acallviewports)
    (princ)
)
(vl-load-com) (princ)

[baker]

Lee,

you are going to kill me. That is great and i will use that lisp.. Is there a way to have another lisp (or the option in this lisp) to put the block's objects to the layer the block is inserted to?

[BlackBox]

Lee,

you are going to kill me. That is great and i will use that lisp.. Is there a way to have another lisp (or the option in this lisp) to put the block's objects to the layer the block is inserted to?

Consider replacing this line:

(list "0" acbylayer "BYLAYER")

... with this one:

(list (vla-get-layer object) acbylayer "BYLAYER")