Lisp to change Layer of text within block

Does anyone know of a lisp routine that will move text and attributes within blocks to a new layer, I have 100 + drawings to change and although i could redefine the blocks in each drawings using design center i will still have to create a template drawing which has over hundred blocks in already.

So to summarise

Step 1 changes layer of text and attribute within blocks to a new layer (eg. "BlockText")

Step 2 batch process across 100 + drawings preferably without having to open them all.

This is an ongoing issue as i am not in control of how the drawings are created or the creation of the blocks. ( i have already tried to educate through that route)

I haven't tested it yet , just modif®ied one of my existing routines and second , appie doesn't check if layer "BlockText" is present

;----------------------------------------------------------------------------------------------------------------------
; RlxOdbxCTL
; Rlx -23 mar 2017
; Change text layer all (m)text's & attributes
;----------------------------------------------------------------------------------------------------------------------
(defun c:RlxOdbxCTL
      ( / acApp acDocs objDBX all-open start sourcefolder subfolder file filelist doc  newlayer)
 (RlxOdbxCTL_Init)
 (if (and (setq newlayer (getstring "\nNew layer for entities : "))
   (setq sourcefolder (RlxOdbxCTL_GetFolder "\nSelect source folder: ")))
   (progn
     (setq start (car (_vl-times)))
     (foreach subfolder (getsubdirlist sourcefolder)
(foreach file (vl-directory-files subfolder "*.dwg" 1)
  (if (wcmatch (strcase file t) "*.dwg")
    (setq filelist (cons (strcat subfolder "\\" file) filelist)))))))
 (if filelist (princ (strcat "\nProcessing " (itoa (length filelist)) " drawings..."))
   (princ "\nNo drawings were found..."))
 
 (foreach file filelist
   (setq doc (odbx_open file)) (RlxOdbxCTL_ProcessEntities) (vla-saveas doc file))
 
 (vlax-release-object objDBX)(vlax-release-object acDocs)(vlax-release-object acApp)
 ;;;for testing
 (princ (strcat "\n\nProcessed  " (itoa (length filelist)) " drawings in "
   (rtos (/ (- (car (_VL-TIMES)) start) 1000.) 2 4) " secs."))
)
   
(defun RlxOdbxCTL_ProcessEntities ( / laycol lay layout obj )
 (setq laycol (vla-get-layers doc))
 (if (vl-catch-all-error-p (setq lay (vl-catch-all-apply 'vla-item (list laycol newlayer))))
   (vl-catch-all-apply 'vla-add (list laycol newlayer)))
 
 (vlax-for layout (vla-get-layouts doc)
   (vlax-for obj (vla-get-block layout)
     (RlxOdbxCTL_CheckObjectLayer obj)
   )
 )
)
(defun RlxOdbxCTL_CheckObjectLayer ( object / bn bent)
 
 (cond
   ((member (vla-get-objectname object) '("AcDbText" "AcDbMText"))
    (check_Layer object))
   ((and (= (vla-get-objectname object) "AcDbBlockReference")(setq bent (get-block-ent object)))
    (mapcar '(lambda(x)(check_Layer x)) bent))
 )
)
(defun check_Layer (%e)
 (if (/= (vlax-get-property %e 'layer) newlayer)
   (vl-catch-all-apply 'vlax-put-property (list %e 'layer newlayer)) ))
(defun get-block-ent ( b / bn lst block ent)
 (setq bn (vla-Get-EffectiveName b))
 ;;; get attributes
 (if (eq :vlax-true (vla-get-HasAttributes b))(setq lst (vlax-invoke b 'GetAttributes)))
 ;;; get text entities
 (vlax-for block (vla-get-Blocks doc)
   (if (eq (vla-get-name block) bn)
     (vlax-for ent block
(if (member (vla-get-objectname ent) '("AcDbText" "AcDbMText"))
  (setq lst (cons ent lst)))))) lst)
(defun RlxOdbxCTL_Init (/ acVer)
 (vl-load-com)
 (setq acApp (vlax-get-acad-object) acDocs (vla-get-documents acApp)
actDoc (vla-get-ActiveDocument acApp) acVer (atoi (getvar "ACADVER")))
 (setq all-open (vlax-for dwg acDocs (setq all-open (cons (strcase (vla-get-fullname dwg)) all-open))))
 (setq objDBX (vl-catch-all-apply 'vla-getinterfaceobject (list acApp (if (< acVer 16)
 "objectdbx.axdbdocument" (strcat "objectdbx.axdbdocument." (itoa acVer))))))
 (if (or (void objDBX)(vl-catch-all-error-p objDBX))(setq objDBX nil)))
(defun RlxOdbxCTL_ReleaseAll ()
 (mapcar '(lambda(x)(if (and (= 'vla-object (type x)) (not (vlax-object-released-p x)))
        (vlax-release-object x))(set (quote x) nil))
      (list actDoc acDocs objDBX acApp)) (gc))
(defun void (x) (if (member x (list "" " " "  " "   " " " nil '())) t nil))
(defun *error* (s) (princ s)(RlxOdbxCTL_Exit))
(defun RlxOdbxCTL_Exit () (RlxOdbxCTL_ReleaseAll))
(defun odbx_open (dwg)
 (if objDBX (if (member (strcase dwg) all-open)
       (odbx_open_copy (findfile dwg))(vla-open objDBX (findfile dwg))))  objDBX)
(defun odbx_open_copy (dwg / copy)
 (vl-file-copy (findfile dwg) (setq copy (vl-filename-mktemp nil nil ".dwg")))
 (vla-open objDBX (findfile copy)) objDBX)
     

(defun RlxOdbxCTL_GetFolder (msg / sh objFolder objParentFolder strPath)
 (setq sh (vla-getInterfaceObject (vlax-get-acad-object) "Shell.Application" ))
 (setq objFolder  (vlax-invoke sh 'BrowseForFolder 0 msg 0 ""))
 (if objFolder 
  (and
    (setq strTitle (vlax-get objFolder "Title"))
    (setq objParentFolder (vlax-get objFolder 'ParentFolder))
    (setq strPath (vlax-get (vlax-invoke objParentFolder "Parsename" strTitle) "Path"))
    (vlax-release-object objParentFolder)
    (vlax-release-object objFolder))
  (vlax-release-object sh)
 )
 strPath
)
(defun GetSubDirList (strPath / lstDirectories)
 (setq lstDirectories (SearchSubDirectories strPath (list strPath))))
(defun SearchSubDirectories (strPath lstDirectories )
 (foreach strDirectory (vl-directory-files strPath nil -1)
   (if (not (member strDirectory (list "." ".." "...")))
     (progn
(setq lstDirectories (cons (strcat strPath "\\" strDirectory) lstDirectories))
(setq lstDirectories (SearchSubDirectories (strcat strPath "\\" strDirectory) lstDirectories)))))
 (reverse lstDirectories))


(C:RlxOdbxCTL)

gr.R.

Many thanks for the quick response i have run a test on a directory with a couple of drawing Autocad returns an error

"Automation Error. Key not found"

Any ideas?

Also can it be modified to create a layer to put the text on or to specify a layer at the command prompt before batch processing

Cheers

Drwhobe

Many thanks for the quick response i have run a test on a directory with a couple of drawing Autocad returns an error

 

"Automation Error. Key not found"

 

Any ideas?

 

Also can it be modified to create a layer to put the text on or to specify a layer at the command prompt before batch processing

 

Cheers

 

Drwhobe

I have updated above code in post #2 , added vl-load-com , added getstring for layer name and check if layer is present... so , round number 2...

gr. R

Once again thx for the quick response. You're a legend:)

It worked for all text in blocks.

It didn't relayer the attributes but that is actually not an issue for the target drawings.

However it also relayered all the text in the drawing as well.

Is there a way to make it only change the text within blocks?

Drwhobe

Once again thx for the quick response. You're a legend:)

 

It worked for all text in blocks.

 

It didn't relayer the attributes but that is actually not an issue for the target drawings.

 

However it also relayered all the text in the drawing as well.

 

Is there a way to make it only change the text within blocks?

 

Drwhobe

sure , just remove the following line in RlxOdbxCTL_CheckObjectLayer :

 ((member (vla-get-objectname object) '("AcDbText" "AcDbMText"))
    (check_Layer object))

Attributes should also be relayerd but if they are color bylayer and your block is in another layer the result may not be obvious.

gr.R.

Brilliant worked a treat

(so wish i had sat closer to the front at school:))

Drwhobe

Brilliant worked a treat

 

(so wish i had sat closer to the front at school:))

 

Drwhobe

Glad 2b of help :-)

Rlx