全局更改文本h的列表
您好，是否有任何人拥有lisp例程，可以全局更改块中文本、多行文字和属性的高度和宽度因子：（。非常感谢您的帮助。谢谢
勇气犬 这是一种在块定义和现有插入中更改它的粗略方法。
但要小心预格式化的多行文字。
(defun c:Redefine_Block_Text (/ *error* itemp GetName ENT OBJ UFLAG)
(vl-load-com)
;; Lee Mac~11.03.10
(defun *error* (msg)
(and uFlag (vla-EndUndoMark *doc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ))
(defun itemp (collection item / result)
(if (not (vl-catch-all-error-p
(setq result (vl-catch-all-apply (function vla-item)
(list collection item)))))
result))
(setq *doc (cond (*doc) ((vla-get-ActiveDocument
(vlax-get-acad-object)))))
(setq GetName (lambda (obj) (if (vlax-property-available-p obj 'EffectiveName)
(vla-get-EffectiveName obj)
(vla-get-Name obj))))
(or *hdef* (setq *hdef* 1.0))
(or *twid* (setq *twid* 1.0))
(while
(progn
(setq ent (car (entsel "\nSelect Block to Change: ")))
(cond ((eq 'ENAME (type ent))
(if (eq "AcDbBlockReference"
(vla-get-Objectname
(setq obj (vlax-ename->vla-object ent))))
(progn
(setq uFlag (not (vla-StartUndoMark *doc)))
(initget 6)
(setq *hdef* (cond ((getdist "\nSpecify New Text Height: ")) (*hdef*)))
(initget 6)
(setq *twid* (cond ((getdist "\nSpecify Text Width Factor: ")) (*twid*)))
(if (ssget "_X" (list (cons 0 "INSERT") (cons 2 (GetName obj)) (cons 66 1)))
(progn
(vlax-for sObj (setq ss (vla-get-ActiveSelectionSet *doc))
(foreach att (append (vlax-invoke sObj 'GetAttributes)
(vlax-invoke sObj 'GetConstantAttributes))
(vla-put-Height att *hdef*)
(if (eq :vlax-false (vla-get-MTextAttribute att))
(vla-put-ScaleFactor att *twid*)
(vla-put-TextString att (strcat "{\\W" (vl-princ-to-string *twid*) ";"
(vla-get-TextString att) "}")))))
(vla-delete ss)))
(vlax-for sub (itemp (vla-get-Blocks *doc) (GetName obj))
(cond ((vl-position (vla-get-ObjectName sub) '("AcDbText" "AcDbAttributeDefinition"))
(vla-put-Height sub *hdef*)
(vla-put-ScaleFactor sub *twid*))
((eq "AcDbMText" (vla-get-ObjectName sub))
(vla-put-Height sub *hdef*)
(vla-put-TextString sub (strcat "{\\W" (vl-princ-to-string *twid*) ";"
(vla-get-TextString sub) "}")))))
(setq uFlag (vla-EndUndomark *doc))
(vla-Regen *doc AcActiveViewport))
(princ "\n** Object Must be a Block **"))))))
(princ))
尚未测试。。。但这一定是另一个伟大的惯例。。。你怎么能这么快？
我无法想象你的大脑处于顶端。。。数字和漂浮在周围的东西。。。我是我办公室的autocad解决方案负责人，我用过你的一些Lisp。。。我必须考虑开始付款
但是，我甚至还没有创建我的paypal帐户。。。我想当我决定开始使用paypal时，我会付钱的。。。。
它就像我打字一样快。。。我确切地知道我想要使用的过程，以及使用什么等。我使用一些代码块，如错误处理程序，以避免反复键入它。。。但实际上这只是练习。
我的Lisp程序没有付款要求。。。我写它们是为了消遣（和这里的大多数成员一样），但当然，我们都很乐意接受捐款
向论坛捐款。没有它，这一切都不可能。 李，你好，
是否有可能在选定数量的块上执行此操作？如果是的话，那太好了，因为这就是我一直在寻找的！
谢谢
geonor公司 我已经有一段时间没有看了，但我知道当前代码将改变所选块的所有引用-您是否希望选择多个不同的块？ 谢谢你的回复。
问题是，数据已从GIS导出到DXF。块的名称基于GIS中的对象类别和对象的唯一句柄。这意味着，有相同类型的区块（例如下水道人孔），但区块名称不同。这就像有1000份相同引用的副本（每个副本有不同的块/引用名称）。对于所有这些，我想更改所有包含文本的宽度/高度。所以我一直在研究的是一个过程，它允许修改一个块中的所有文本，以获得多个选定的块。 嗨，试试这个：
(defun c:RedefineBlockText ( / *error* doc blocks GetName ss undo )
(vl-load-com)
;; © Lee Mac 2010
(defun *error* ( msg )
(and undo (vla-EndUndoMark doc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
blocks (vla-get-Blocks doc))
(setq GetName
(lambda ( obj )
(if (vlax-property-available-p obj 'EffectiveName)
(vla-get-EffectiveName obj)
(vla-get-Name obj)
)
)
)
(mapcar '(lambda ( sym val ) (or (boundp sym) (set sym val))) '(*hdef* *twid*) '(1. 1.))
(if (setq ss (ssget "_:L" '((0 . "INSERT"))))
(
(lambda ( i / e o n done atts sub )
(initget 6)
(setq *hdef* (cond ( (getdist "\nSpecify New Text Height: ") ) ( *hdef* )))
(initget 6)
(setq *twid* (cond ( (getdist "\nSpecify Text Width Factor: ") ) ( *twid* )))
(setq undo (not (vla-StartUndoMark doc)))
(while (setq e (ssname ss (setq i (1+ i))))
(setq o (vlax-ename->vla-object e))
(if (not (vl-position (setq n (GetName o)) done))
(progn
(if (setq atts (ssget "_X" (list (cons 0 "INSERT") (cons 2 n) (cons 66 1))))
(
(lambda ( j / f p att )
(while (setq f (ssname atts (setq j (1+ j))))
(setq p (vlax-ename->vla-object f))
(foreach att (append (vlax-invoke p 'GetAttributes)
(vlax-invoke p 'GetConstantAttributes))
(vla-put-Height att *hdef*)
(if (eq :vlax-false (vla-get-MTextAttribute att))
(vla-put-ScaleFactor att *twid*)
(vla-put-TextString att
(strcat "{\\W" (vl-princ-to-string *twid*) ";" (vla-get-TextString att) "}")
)
)
)
)
)
-1
)
)
(vlax-for sub (LM:Itemp Blocks n)
(cond
( (vl-position (vla-get-ObjectName sub) '("AcDbText" "AcDbAttributeDefinition"))
(vla-put-Height sub *hdef*)
(vla-put-ScaleFactor sub *twid*)
)
( (eq "AcDbMText" (vla-get-ObjectName sub))
(vla-put-Height sub *hdef*)
(vla-put-TextString sub
(strcat "{\\W" (vl-princ-to-string *twid*) ";" (vla-get-TextString sub) "}")
)
)
)
)
(setq done (cons n done))
)
)
)
(setq undo (vla-EndUndoMark doc))
(vla-Regen doc AcActiveViewport)
)
-1
)
)
(princ)
)
;;-----------------------=={ Itemp }==------------------------;;
;; ;;
;;Retrieves the item with index 'item' if present in the ;;
;;specified collection, else nil ;;
;;------------------------------------------------------------;;
;;Author: Lee McDonnell, 2010 ;;
;; ;;
;;Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;;Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
;;Arguments: ;;
;;coll - the VLA Collection Object ;;
;;item - the index of the item to be retrieved ;;
;;------------------------------------------------------------;;
;;Returns:the VLA Object at the specified index, else nil ;;
;;------------------------------------------------------------;;
(defun LM:Itemp ( coll item )
;; © Lee Mac 2010
(if
(not
(vl-catch-all-error-p
(setq item
(vl-catch-all-apply
(function vla-item) (list coll item)
)
)
)
)
item
)
) 测试和享受，
这套程序非常有效，而且做得非常完美。
太棒了，非常感谢。。。
页:
[1]
2