[编程交流] Lisp更改文字层w

;----------------------------------------------------------------------------------------------------------------------
; 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)

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