[分享]：得到块的属性,改块的属性

aeo · 发表于 2003-6-26 21:41:46

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

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

×

;;;;;*********************************得到所有属性 '((tag1 text1)(tag2 text2).......)
(defun get-att (e / a)
(setq a (vlax-ename->vla-object e))
(if (and
(= "AcDbBlockReference" (vla-get-objectname a))
(= ':vlax-true (vlax-get-property a 'HasAttributes))
)
(progn
(setq a (vla-GetAttributes a)
a (vlax-safearray->list (vlax-variant-value a))
)
(mapcar
'(lambda (x)
(list (vlax-get-property x 'TagString)
(vlax-get-property x 'TextString)
)
)
a
)
)
nil
)
)
;;;;;;;********************************改属性
;(change-att nil newstr) 改第一个属性
;(change-att tag newstr) 改那个tag标签属性
;(change-att (list tag1 tag2..)(list new1 new2...)) 一个个改
(defun change-att (e tag str / a b)
(setq a (vlax-ename->vla-object e))
(if (= ':vlax-true (vlax-get-property a 'HasAttributes))
(progn
(setq a (vla-GetAttributes a)
a (vlax-safearray->list (vlax-variant-value a))
)
(cond
((and
(null tag)
(= 'STR (type str))
)
(vlax-put-property (car a) 'TextString str)
)
((and
(= 'STR (type tag))
(= 'STR (type str))
)
(foreach k a
(if (= tag (vlax-get-property k 'TagString))
(vlax-put-property k 'TextString str)
)
)
)
((and
(listp tag)
(listp str)
)
(foreach k a
(if (member (setq b (vlax-get-property k 'TagString))
tag
)
(vlax-put-property k 'TextString (nth (vl-position b tag) str))
)
)
)
)
(vla-update (vlax-ename->vla-object e))
)
)
)

;;;;;*********************************得到所有属性 '((tag1 text1)(tag2 text2).......) 
(defun get-att (e / a) 
  (setq a (vlax-ename->vla-object e)) 
  (if (and 
        (= "AcDbBlockReference" (vla-get-objectname a)) 
        (= ':vlax-true (vlax-get-property a 'HasAttributes)) 
      ) 
    (progn 
      (setq a (vla-GetAttributes a) 
            a (vlax-safearray->list (vlax-variant-value a)) 
      ) 
      (mapcar 
        '(lambda (x) 
           (list (vlax-get-property x 'TagString) 
                 (vlax-get-property x 'TextString) 
           ) 
         ) 
        a 
      ) 
    ) 
    nil 
  ) 
) 
 
;;;;;;;********************************改属性 
                                      ;(change-att nil newstr) 改第一个属性 
                                      ;(change-att tag newstr) 改那个tag标签属性 
                                      ;(change-att (list tag1 tag2..)(list new1 new2...)) 一个个改 
                                       
(defun change-att (e tag str / a b) 
  (setq a (vlax-ename->vla-object e)) 
  (if (= ':vlax-true (vlax-get-property a 'HasAttributes)) 
    (progn 
      (setq a (vla-GetAttributes a) 
            a (vlax-safearray->list (vlax-variant-value a)) 
      ) 
      (cond 
        ((and 
           (null tag) 
           (= 'STR (type str)) 
         ) 
          (vlax-put-property (car a) 'TextString str) 
        ) 
        ((and 
           (= 'STR (type tag)) 
           (= 'STR (type str)) 
         ) 
          (foreach k a 
            (if (= tag (vlax-get-property k 'TagString)) 
              (vlax-put-property k 'TextString str) 
            ) 
          ) 
        ) 
        ((and 
           (listp tag) 
           (listp str) 
         ) 
          (foreach k a 
            (if (member (setq b (vlax-get-property k 'TagString)) 
                        tag 
                ) 
              (vlax-put-property k 'TextString (nth (vl-position b tag) str)) 
            ) 
          ) 
        ) 
      ) 
      (vla-update (vlax-ename->vla-object e)) 
    ) 
  ) 
)

luran · 发表于 2003-6-27 08:44:34

斑竹，这个怎么用啊？为什么说参数太少呢？
另外，能不能编一个，先将选中的部分做成块，然后定义几个属性，再然后编辑这些属性，
这个过程一气呵成，那就爽了。做块程序如下：
code: (defun c:test (/ ss)
  (setq ss (ssget))
  (command ".copybase" (getvar "viewctr") ss "")
  (command ".erase" ss "")
  (command ".pasteblock" (getvar "viewctr"))
  (princ)
)

eachy · 发表于 2003-6-27 18:53:46

这样改了下

(defun GetAttributes (obj / lst)
;(vl-load-com)
(if (safearray-value
(setq lst (vlax-variant-value
(vla-getattributes obj)
)
)
)
(mapcar '(lambda (x)
(list (vla-get-tagstring x)
(vla-get-textstring x)
(vlax-vla-object->ename x)
)
)
(vlax-safearray->list lst)
)
)
)
;;;;;
;;e 块实体 attlst 属性表 ((tag1 txt1) (tag2 txt2) (tag3 (tagn txt3)) ...)
(defun ch-att (e attlst / obj att txtobj)
(setq obj (vlax-ename->vla-object e))
(if (wcmatch (vla-get-objectname obj) "*Blcok*")
(if (= ':vlax-true (vlax-get-property obj 'HasAttributes))
(progn
(setq att (GetAttributes obj))
(foreach x attlst
(setq txtobj (last (assoc (car x) att)))
(if txtobj
(cond
((= 'LIST (type (cadr x)))
(vla-put-tagstring
(vlax-ename->vla-object txtobj)
(caadr x)
)
(vla-put-textstring
(vlax-ename->vla-object txtobj)
(cadadr x)
)
)
(t
(vla-put-textstring
(vlax-ename->vla-object txtobj)
(cadr x)
)
)
)
)
)
)
)
)
)

(defun GetAttributes (obj / lst) 
  ;(vl-load-com) 
  (if (safearray-value 
        (setq lst (vlax-variant-value 
                    (vla-getattributes obj) 
                  ) 
        ) 
      ) 
    (mapcar '(lambda (x) 
               (list (vla-get-tagstring x) 
                     (vla-get-textstring x) 
                     (vlax-vla-object->ename x) 
               ) 
             ) 
            (vlax-safearray->list lst) 
    ) 
  ) 
) 
;;;;; 
;;e 块实体  attlst 属性表 ((tag1 txt1) (tag2 txt2) (tag3 (tagn txt3)) ...) 
(defun ch-att        (e attlst / obj att txtobj) 
  (setq obj (vlax-ename->vla-object e)) 
  (if (wcmatch (vla-get-objectname obj) "*Blcok*") 
    (if        (= ':vlax-true (vlax-get-property obj 'HasAttributes)) 
      (progn 
        (setq att (GetAttributes obj)) 
        (foreach x attlst 
          (setq txtobj (last (assoc (car x) att))) 
          (if txtobj 
            (cond 
              ((= 'LIST (type (cadr x))) 
               (vla-put-tagstring 
                 (vlax-ename->vla-object txtobj) 
                 (caadr x) 
               ) 
               (vla-put-textstring 
                 (vlax-ename->vla-object txtobj) 
                 (cadadr x) 
               ) 
              ) 
              (t 
               (vla-put-textstring 
                 (vlax-ename->vla-object txtobj) 
                 (cadr x) 
               ) 
              ) 
            ) 
          ) 
        ) 
      ) 
    ) 
  ) 
)

aeo · 发表于 2003-6-27 21:16:32

你这么写,有违我的初衷:

(get-att (car(entsel))--->不管点到什么,都能安全退出.

(chang-att ..)
为什么要三种可能:1-很多图块只有一个属性,就不要刨根问底tag是什么了.
                              2-只改里面的一个tag省得忘了list...
                              3-写程序,肯定是所有的tag的一个表放在手头了,拿过来就用.或者拎几个出来.
                                 当然第三种改成你的也行,和get相配.或者把你的设成第四种情况.(change-att list nil)

434939575 · 发表于 2014-9-17 19:45:03

非常感谢。今天用到了。谢谢！

liushengri1 · 发表于 2014-9-20 21:45:11

谢谢了{:soso_e189:}

账号		自动登录	找回密码
密码			立即注册

[分享]：得到块的属性,改块的属性

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子