Lisp更改文字层w
有谁知道lisp例程会将块中的文本和属性移动到新层吗？我有100多个图形要更改，虽然我可以使用design center重新定义每个图形中的块，但我仍然需要创建一个模板图形，其中已经有100多个块。总结一下
步骤1将块内的文本层和属性更改为新层（例如“块文本”）
第2步：批量处理100多张图纸，最好不必全部打开。
这是一个持续的问题，因为我无法控制如何创建图形或创建块。（我已经尝试过通过这条途径进行教育） 我还没有测试它，只是修改了我现有的一个例程，其次，appie没有检查层“BlockText”是否存在
;----------------------------------------------------------------------------------------------------------------------
; 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 docnewlayer)
(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。 非常感谢您的快速响应，我在一个目录下运行了一个测试，Autocad返回了一个错误
“自动化错误。找不到密钥”
有什么想法吗？
还可以对其进行修改，以创建一个图层来放置文本，或在批处理之前在命令提示下指定一个图层
干杯
Whobe博士
我在帖子#2中更新了上述代码，添加了vl load com，为层名称添加了getstring，并检查层是否存在。。。所以，第二轮。。。
gr.R 再次感谢您的快速响应。你是一个传奇：）
它适用于块中的所有文本。
它没有重新层化属性，但这实际上不是目标图形的问题。
然而，它也转述了图纸中的所有文本。
有没有办法让它只改变块内的文本？
Whobe博士
当然，只需删除RlxOdbxCTL\u CheckObjectLayer中的以下行：
((member (vla-get-objectname object) '("AcDbText" "AcDbMText"))
(check_Layer object))
属性也应该重新层化，但如果它们是按颜色层，并且块位于另一层，则结果可能不明显。
gr.R。 Brilliant做了一件好事
（但愿我在学校坐得离前面近一点：）
Whobe博士
很高兴得到帮助：-）
Rlx公司
页:
[1]