设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 属性块参数复制到另一个属性块
1234下一页
返回列表 发新帖
查看: 5627|回复: 37

[源码] 属性块参数复制到另一个属性块

[复制链接]
shujh1989
发表于 2023-10-8 21:32:10 | 显示全部楼层 |阅读模式
本帖最后由 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)
)


回复

使用道具 举报

飞雪神光
发表于 2023-10-10 13:07:31 | 显示全部楼层
就像这样 拾取一个原图块 批量覆盖有相同属性的属性块 不考虑数据是否对等
  1. (defun c:tt(/ bj get-insert-tag&value lm-set-attribute obj ss ss-enlst sx sxlst ty)
  2.         (defun get-insert-Tag&value (blk / lst)
  3.                 (if (= (type blk) 'ENAME)
  4.                         (if        (safearray-value(setq        lst (vlax-variant-value(vla-getattributes (vlax-ename->vla-object blk)))))
  5.                                 (mapcar'(lambda (x)(cons (vla-get-tagstring x) (vla-get-textstring x)))(vlax-safearray->list lst))
  6.                         )
  7.                         nil
  8.                 )
  9.         )
  10.         (defun lm-set-attribute(ty biaoji va / att_list)
  11.                 (setq ty (if(=(type ty)'ename)(vlax-ename->vla-object ty)ty))
  12.                 (setq att_list (vlax-safeArray->list (vlax-variant-value (vla-getattributes ty))))
  13.                 (setq xx(vl-some'(lambda(a)(if(=(strcase(vla-get-TagString a))(strcase biaoji))a))att_list))
  14.                 (if xx
  15.                         (vla-put-textstring xx va)
  16.                 )
  17.                 (princ)
  18.         )
  19.         (setq
  20.                 ty(car(entsel "\n原属性块:"))
  21.                 obj(vlax-ename->vla-object ty)
  22.         )
  23.         (setq sxlst(get-insert-Tag&value ty))
  24.         (princ"\n覆盖属性块：")
  25.         (setq ss(ssget '((0 . "insert"))))
  26.         (foreach ty (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex ss)))
  27.                 (foreach x sxlst
  28.                         (setq
  29.                                 bj(car x)
  30.                                 sx(cdr x)
  31.                         )
  32.                         (lm-set-attribute ty bj sx)
  33.                 )
  34.         )
  35.         (princ)
  36. )

评分

参与人数 1明经币 +1 收起 理由
lxl217114 + 1 很好使，如果能把相近的替换以后，删除原块.

查看全部评分

回复 支持 1 反对 0

使用道具 举报

llsheng_73
发表于 2023-10-10 17:31:27 | 显示全部楼层
飞雪神光 发表于 2023-10-10 13:07
就像这样 拾取一个原图块 批量覆盖有相同属性的属性块 不考虑数据是否对等

块参照的属性是以数组形式出现的，也就是无法使用item,因此，不宜针对一个tag在它的所有属性里边查找
  1. (defun getatts(blk);|获取块参照图元(对象)的属性参照,返回值((属性标记 属性值 属性对象)...)以便进一步修改指定标记的属性值|;
  2.   (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)
  3.     (mapcar(function(lambda(x)(list(strcase(vlax-get-property x'TagString))(vlax-get-property x'TextString)x)))
  4.            (vlax-safearray->list(vlax-variant-value(vlax-invoke-method blk'GetAttributes))))))
  5. (defun putatts(enblk lst / a);|enblk属性块图元或对象,lst((标记 值)(标记 值)(标记 值)...)|;
  6.   (and(setq a(getatts enblk))
  7.       (vl-some(function(lambda(x / b)(and(setq b(assoc(strcase(car x))a))(vlax-put-property(caddr b)'TextString(cadr x)))))lst)))
回复 支持 1 反对 0

使用道具 举报

飞雪神光
发表于 2024-1-10 11:30:39 | 显示全部楼层
lxl217114 发表于 2024-1-10 10:35
大佬，如果方便的话。
看看如图的这样可以实现么？

  1. (defun c:tt(/ bj get-insert-tag&value lm-set-attribute obj ss ss-enlst sx sxlst ty)
  2.         (defun get-insert-Tag&value (blk / lst)
  3.                 (if (= (type blk) 'ENAME)
  4.                         (if (safearray-value(setq lst (vlax-variant-value(vla-getattributes (vlax-ename->vla-object blk)))))
  5.                                 (mapcar'(lambda (x)(cons (vla-get-tagstring x) (vla-get-textstring x)))(vlax-safearray->list lst))
  6.                         )
  7.                         nil
  8.                 )
  9.         )
  10.         (defun lm-set-attribute(ty biaoji va / att_list)
  11.                 (setq ty (if(=(type ty)'ename)(vlax-ename->vla-object ty)ty))
  12.                 (setq att_list (vlax-safeArray->list (vlax-variant-value (vla-getattributes ty))))
  13.                 (setq xx(vl-some'(lambda(a)(if(=(strcase(vla-get-TagString a))(strcase biaoji))a))att_list))
  14.                 (if xx
  15.                         (vla-put-textstring xx va)
  16.                 )
  17.                 (princ)
  18.         )
  19.         (defun ss-enlst (ss / enlst)
  20.                 (cond
  21.                         ((= (type ss) 'PICKSET)
  22.                                 (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
  23.                         )
  24.                         ((= (type ss) 'LIST)
  25.                                 (setq enlst (ssadd))
  26.                                 (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
  27.                         )
  28.                 )
  29.         )
  30.         (defun lm-Get-LwPts(en / x)
  31.                 (mapcar
  32.                         'cdr
  33.                         (vl-remove-if-not
  34.                                 '(lambda(x)
  35.                                          (= (car x) 10)
  36.                                  )
  37.                                 (entget en)
  38.                         )
  39.                 )
  40.         )
  41.         (setq ss(ssget '((0 . "LWPOLYLINE")(8 . "jm-创建块图框"))))
  42.         (foreach ty (ss-enlst ss)
  43.                 (setq pts (lm-Get-LwPts ty))
  44.                 (setq yss(ssget "cp" pts '((0 . "INSERT")(8 . "图签")(2 . "原始图签"))))
  45.                 (if (and yss (> (sslength yss) 0))
  46.                         (progn
  47.                                 (setq
  48.                                         ty (ssname yss 0)
  49.                                         obj(vlax-ename->vla-object ty)
  50.                                         sxlst (get-insert-Tag&value ty)
  51.                                 )
  52.                                 (entdel ty)
  53.                                 (setq xss(ssget "cp" pts '((0 . "INSERT")(2 . "新图签"))))
  54.                                 (foreach ty (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex xss)))
  55.                                         (foreach x sxlst
  56.                                                 (setq
  57.                                                         bj(car x)
  58.                                                         sx(cdr x)
  59.                                                 )
  60.                                                 (lm-set-attribute ty bj sx)
  61.                                         )
  62.                                 )
  63.                         )
  64.                 )
  65.         )
  66.         (princ)
  67. )

评分

参与人数 1明经币 +1 收起 理由
lxl217114 + 1

查看全部评分

回复 支持 反对

使用道具 举报

飞雪神光
发表于 2023-10-8 23:04:02 | 显示全部楼层
直接用原有的去覆盖就行了 有对应属性则覆盖 没有的他自己就跳过了  看代码是操作反了 用被替换的图框去查找原图框属性
回复 支持 反对

使用道具 举报

shujh1989
 楼主| 发表于 2023-10-8 23:23:45 来自手机 | 显示全部楼层
飞雪神光 发表于 2023-10-8 23:04
直接用原有的去覆盖就行了 有对应属性则覆盖 没有的他自己就跳过了  看代码是操作反了 用被替换的图框去查 ...

这个程序是完整的，功能可以实现啊，没有反。ai错的地方是少了一个函数，我的原始程序是只拷三个属性，没有用循环。
回复 支持 反对

使用道具 举报

xiaocainiao
发表于 2023-10-9 08:10:53 | 显示全部楼层
(not (vlax-property-available-p source_obj 'HasAttributes))这个代码好像不能判断是不是属性块吧、我试了一下普通块也不提示
回复 支持 反对

使用道具 举报

shujh1989
 楼主| 发表于 2023-10-9 09:30:38 | 显示全部楼层
xiaocainiao 发表于 2023-10-9 08:10
(not (vlax-property-available-p source_obj 'HasAttributes))这个代码好像不能判断是不是属性块吧、我试 ...

不是判断块的，是判断其他类型对象的，比如选中文字线之类的会提示，有点多余。
回复 支持 反对

使用道具 举报

xiaocainiao
发表于 2023-10-9 10:15:18 | 显示全部楼层
shujh1989 发表于 2023-10-9 09:30
不是判断块的，是判断其他类型对象的，比如选中文字线之类的会提示，有点多余。

好吧、我看注释以为是判断属性块的、特意试了一下
回复 支持 反对

使用道具 举报

飞雪神光
发表于 2023-10-9 12:18:13 | 显示全部楼层
shujh1989 发表于 2023-10-8 23:23
这个程序是完整的，功能可以实现啊，没有反。ai错的地方是少了一个函数，我的原始程序是只拷三个属性，没 ...

我的意思是 如果没反的话 两个属性块的属性排列不必是一样的 数量也可以是不对等的
回复 支持 反对

使用道具 举报

cghdy
发表于 2023-10-9 13:45:39 来自手机 | 显示全部楼层
论坛有批量改属性的，批量改属性都是先获取再移植到别的属性块。
回复 支持 反对

使用道具 举报

shujh1989
 楼主| 发表于 2023-10-9 17:45:50 来自手机 | 显示全部楼层
飞雪神光 发表于 2023-10-9 12:18
我的意思是 如果没反的话 两个属性块的属性排列不必是一样的 数量也可以是不对等的

是可以的。那要把第一个块的属性跟第二个块的每一个属性比较，标签一致的再替换，不一致的跳过。然后去掉替换过的再做成列表，再挨个比较。好复杂，不适合我这个初学者，搞不来。
回复 支持 反对

使用道具 举报

wharan
发表于 2023-10-9 19:30:26 | 显示全部楼层
本帖最后由 wharan 于 2023-10-9 19:34 编辑

我是这么做的：选定样板图框（图标）的共用属性，如：工程名称、项目编号、阶段、版本号、日期等，然后循环，把每个图框（图标）的共用属性修改，保留局部特性，如图名、图号等。

本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x

点评

lxl217114
这个挺厉害的  发表于 2023-10-9 19:53
回复 支持 反对

使用道具 举报

1234下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-11-25 17:30 , Processed in 0.211792 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表