属性块参数复制到另一个属性块
本帖最后由 shujh1989 于 2023-10-9 22:50 编辑(defun C:CCT (/ source_obj target_obj source_attrs target_attrs num-attrs)
(vl-load-com)
(setvar "cmdecho" 0)
; 选择需要复制信息的图框
(setq source_obj (vlax-ename->vla-object (car (entsel "\n选择需要复制信息的图框"))))
; 如果选择的对象不是属性块，退出
(if (not (vlax-property-available-p source_obj 'HasAttributes))
(progn
(alert "选择的对象不是属性块。")
(exit)
)
)
; 选择需要替换信息的图框
(setq target_obj (vlax-ename->vla-object (car (entsel "\n选择需要替换信息的图框"))))
; 如果选择的对象不是属性块，退出
(if (not (vlax-property-available-p target_obj 'HasAttributes))
(progn
(alert "选择的对象不是属性块。")
(exit)
)
)
; 获取属性列表
(setq source_attrs (vlax-safearray->list (vlax-variant-value (vla-GetAttributes source_obj))))
(setq target_attrs (vlax-safearray->list (vlax-variant-value (vla-GetAttributes target_obj))))
; 检查属性数量是否匹配
(setq num-attrs (min (length source_attrs) (length target_attrs)))
(if (< num-attrs 17)
(alert "警告: 属性数量小于17，只复制现有属性。")
)
; 遍历属性列表，从第0到第n-1个属性
(setq i 0)
(while (< i num-attrs)
(vla-put-TextString
(nth i target_attrs)
(vla-get-TextString (nth i source_attrs)))
(setq i (1+ i))
)
(setvar "cmdecho" 1)
)
写这个的原因是想把A0动态属性块图框的信息复制到其他尺寸的图框上去，应用比较局限。一开始写的代码很累赘，用ai优化了下，但是ai犯错了一直运行不了，查了很久才弄清。这个应用的局限性很大，两个属性块的属性排列顺序必须是一样的。如果考虑两个块的属性排列顺序不一样需要比较属性块的tagstring，tagstring一致的再复制信息。我没有这个应用场景，就没搞这么麻烦。程序里标的是图框，其实对属性块都可以用。我用的图框只有17个属性，数量可以改。
升级了下，现在不用考虑属性排序了，可以自动匹配标签一致的属性复制信息。
(defun C:CCT (/ source_obj target_obj source_attrs target_attrs num-attrs)
(vl-load-com)
(setvar "cmdecho" 0)
; 选择需要复制信息的图框
(setq source_obj (vlax-ename->vla-object (car (entsel "\n选择需要复制信息的图框"))))
; 检查选择的对象是否是属性块
(if (not (vlax-property-available-p source_obj 'HasAttributes))
(progn
(alert "选择的对象不是属性块。")
(exit)
)
)
; 选择需要替换信息的图框
(setq target_obj (vlax-ename->vla-object (car (entsel "\n选择需要替换信息的图框"))))
; 检查选择的对象是否是属性块
(if (not (vlax-property-available-p target_obj 'HasAttributes))
(progn
(alert "选择的对象不是属性块。")
(exit)
)
)
; 获取属性列表
(setq source_attrs (vlax-safearray->list (vlax-variant-value (vla-GetAttributes source_obj))))
(setq target_attrs (vlax-safearray->list (vlax-variant-value (vla-GetAttributes target_obj))))
; 检查属性数量是否匹配
(setq num-attrs (min (length source_attrs) (length target_attrs)))
(if (< num-attrs 17)
(alert "警告: 属性数量小于17，只复制现有属性。")
)
; 遍历属性列表并复制属性
(setq i 0)
(while (< i num-attrs)
(setq target_attr (nth i target_attrs))
(setq source_attr (nth i source_attrs))
(setq j 0)
(while (< j num-attrs)
(setq target_attr_2 (nth j target_attrs))
(setq tagstring_source (vla-get-TagString source_attr))
(setq tagstring_target (vla-get-TagString target_attr_2))
(if (equal tagstring_source tagstring_target) ; 检查tagstring是否相同
(vla-put-TextString target_attr_2 (vla-get-TextString source_attr)) ; 如果相同，则复制textstring到目标属性中
) ; 如果tagstring不同，则不执行复制操作
(setq j (1+ j))
)
(setq i (1+ i))
)
(setvar "cmdecho" 1)
)
就像这样 拾取一个原图块 批量覆盖有相同属性的属性块 不考虑数据是否对等(defun c:tt(/ bj get-insert-tag&value lm-set-attribute obj ss ss-enlst sx sxlst ty)
(defun get-insert-Tag&value (blk / lst)
(if (= (type blk) 'ENAME)
(if (safearray-value(setq lst (vlax-variant-value(vla-getattributes (vlax-ename->vla-object blk)))))
(mapcar'(lambda (x)(cons (vla-get-tagstring x) (vla-get-textstring x)))(vlax-safearray->list lst))
)
nil
)
)
(defun lm-set-attribute(ty biaoji va / att_list)
(setq ty (if(=(type ty)'ename)(vlax-ename->vla-object ty)ty))
(setq att_list (vlax-safeArray->list (vlax-variant-value (vla-getattributes ty))))
(setq xx(vl-some'(lambda(a)(if(=(strcase(vla-get-TagString a))(strcase biaoji))a))att_list))
(if xx
(vla-put-textstring xx va)
)
(princ)
)
(setq
ty(car(entsel "\n原属性块:"))
obj(vlax-ename->vla-object ty)
)
(setq sxlst(get-insert-Tag&value ty))
(princ"\n覆盖属性块：")
(setq ss(ssget '((0 . "insert"))))
(foreach ty (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex ss)))
(foreach x sxlst
(setq
bj(car x)
sx(cdr x)
)
(lm-set-attribute ty bj sx)
)
)
(princ)
) 飞雪神光 发表于 2023-10-10 13:07
就像这样 拾取一个原图块 批量覆盖有相同属性的属性块 不考虑数据是否对等
块参照的属性是以数组形式出现的，也就是无法使用item,因此，不宜针对一个tag在它的所有属性里边查找
(defun getatts(blk);|获取块参照图元(对象)的属性参照,返回值((属性标记 属性值 属性对象)...)以便进一步修改指定标记的属性值|;
(if(equal(VL-CATCH-ALL-APPLY(function vlax-get-property)(list(setq blk(if(=(type blk)'ename)(vlax-ename->vla-object blk)blk))'HasAttributes)):vlax-true)
(mapcar(function(lambda(x)(list(strcase(vlax-get-property x'TagString))(vlax-get-property x'TextString)x)))
(vlax-safearray->list(vlax-variant-value(vlax-invoke-method blk'GetAttributes))))))
(defun putatts(enblk lst / a);|enblk属性块图元或对象,lst((标记 值)(标记 值)(标记 值)...)|;
(and(setq a(getatts enblk))
(vl-some(function(lambda(x / b)(and(setq b(assoc(strcase(car x))a))(vlax-put-property(caddr b)'TextString(cadr x)))))lst))) lxl217114 发表于 2024-1-10 10:35
大佬，如果方便的话。
看看如图的这样可以实现么？
(defun c:tt(/ bj get-insert-tag&value lm-set-attribute obj ss ss-enlst sx sxlst ty)
(defun get-insert-Tag&value (blk / lst)
(if (= (type blk) 'ENAME)
(if (safearray-value(setq lst (vlax-variant-value(vla-getattributes (vlax-ename->vla-object blk)))))
(mapcar'(lambda (x)(cons (vla-get-tagstring x) (vla-get-textstring x)))(vlax-safearray->list lst))
)
nil
)
)
(defun lm-set-attribute(ty biaoji va / att_list)
(setq ty (if(=(type ty)'ename)(vlax-ename->vla-object ty)ty))
(setq att_list (vlax-safeArray->list (vlax-variant-value (vla-getattributes ty))))
(setq xx(vl-some'(lambda(a)(if(=(strcase(vla-get-TagString a))(strcase biaoji))a))att_list))
(if xx
(vla-put-textstring xx va)
)
(princ)
)
(defun ss-enlst (ss / enlst)
(cond
((= (type ss) 'PICKSET)
(vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
)
((= (type ss) 'LIST)
(setq enlst (ssadd))
(last (mapcar '(lambda (x) (ssadd x enlst)) ss))
)
)
)
(defun lm-Get-LwPts(en / x)
(mapcar
'cdr
(vl-remove-if-not
'(lambda(x)
(= (car x) 10)
)
(entget en)
)
)
)
(setq ss(ssget '((0 . "LWPOLYLINE")(8 . "jm-创建块图框"))))
(foreach ty (ss-enlst ss)
(setq pts (lm-Get-LwPts ty))
(setq yss(ssget "cp" pts '((0 . "INSERT")(8 . "图签")(2 . "原始图签"))))
(if (and yss (> (sslength yss) 0))
(progn
(setq
ty (ssname yss 0)
obj(vlax-ename->vla-object ty)
sxlst (get-insert-Tag&value ty)
)
(entdel ty)
(setq xss(ssget "cp" pts '((0 . "INSERT")(2 . "新图签"))))
(foreach ty (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex xss)))
(foreach x sxlst
(setq
bj(car x)
sx(cdr x)
)
(lm-set-attribute ty bj sx)
)
)
)
)
)
(princ)
) 直接用原有的去覆盖就行了 有对应属性则覆盖 没有的他自己就跳过了看代码是操作反了 用被替换的图框去查找原图框属性 飞雪神光 发表于 2023-10-8 23:04
直接用原有的去覆盖就行了 有对应属性则覆盖 没有的他自己就跳过了看代码是操作反了 用被替换的图框去查 ...
这个程序是完整的，功能可以实现啊，没有反。ai错的地方是少了一个函数，我的原始程序是只拷三个属性，没有用循环。 (not (vlax-property-available-p source_obj 'HasAttributes))这个代码好像不能判断是不是属性块吧、我试了一下普通块也不提示 xiaocainiao 发表于 2023-10-9 08:10
(not (vlax-property-available-p source_obj 'HasAttributes))这个代码好像不能判断是不是属性块吧、我试 ...
不是判断块的，是判断其他类型对象的，比如选中文字线之类的会提示，有点多余。 shujh1989 发表于 2023-10-9 09:30
不是判断块的，是判断其他类型对象的，比如选中文字线之类的会提示，有点多余。
好吧、我看注释以为是判断属性块的、特意试了一下 shujh1989 发表于 2023-10-8 23:23
这个程序是完整的，功能可以实现啊，没有反。ai错的地方是少了一个函数，我的原始程序是只拷三个属性，没 ...
我的意思是 如果没反的话 两个属性块的属性排列不必是一样的 数量也可以是不对等的 论坛有批量改属性的，批量改属性都是先获取再移植到别的属性块。 飞雪神光 发表于 2023-10-9 12:18
我的意思是 如果没反的话 两个属性块的属性排列不必是一样的 数量也可以是不对等的
是可以的。那要把第一个块的属性跟第二个块的每一个属性比较，标签一致的再替换，不一致的跳过。然后去掉替换过的再做成列表，再挨个比较。好复杂，不适合我这个初学者，搞不来。 本帖最后由 wharan 于 2023-10-9 19:34 编辑
我是这么做的：选定样板图框（图标）的共用属性，如：工程名称、项目编号、阶段、版本号、日期等，然后循环，把每个图框（图标）的共用属性修改，保留局部特性，如图名、图号等。