块中套块的实体修改其中的图元属性的实现

Free-Lancer · 发表于 2013-4-20 20:43:58

再简化下
[pcode=lisp,true](defun c:tt (/ thisdrawing blocks chgblkcol)
  (defun chgblkcol (bn /)
(vlax-for obj (vla-item blocks bn)
   (vlax-put obj acbyblock)
   (if (wcmatch (vla-get-objectname "AcDbBlockReference"))
         (chgblkcol (vla-get-objectname obj))
   )
)
  )
  (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object))
      blocks       (vla-get-blocks thisdrawing)
  )
  (if (ssget '((0 . "insert")))
(vlax-for obj (vla-get-activeselectionset thisdrawing) ;_有时有Bug
   (chgblkcol (vla-get-name obj))
   (vla-put-color obj 4)
)
  )
  (princ)
)[/pcode]

Free-Lancer · 发表于 2013-4-20 21:01:00

解密下院长的函数
[pcode=lisp,true](defun *Thisdrawing* ()
  (vla-get-activedocument (vlax-get-acad-object))
)
(defun xyp-e2o (e)
  (vlax-ename->vla-object e)
)
(defun xyp-block-objlist (obj / lst)
  (vlax-for x (vla-item       (vla-get-blocks
                        (*Thisdrawing*)
                     )
                     (vla-get-name obj)
            )
(if       (wcmatch (vla-get-objectname x) "AcDbBlockReference")
   (setq lst (cons (xyp-block-objlist x) lst))
   (setq lst (cons x lst))
)
  )
  lst
)[/pcode]

xyp1964 · 发表于 2013-4-20 21:04:35

(defun xyp-Block-ObjList (obj / vlst)
(setq po (vlax-get obj "InsertionPoint"))
(defun bbb (obj / x)
(vlax-for x (vla-item (vla-get-Blocks
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(vla-get-name obj)
)
(if (= (vla-get-objectname x) "AcDbBlockReference")
(progn
(setq po (vlax-get x "InsertionPoint"))
(bbb x)
)
)
(setq vlst (cons (list po x) vlst))
)
)
(bbb obj)
)

Highflybird · 发表于 2013-4-20 21:28:22

似乎这个题目如果不用递归的话，就没办法了吗？呵呵

XDSoft · 发表于 2013-4-20 21:42:35

Highflybird 发表于 2013-4-20 21:28

登录/注册后可看大图

似乎这个题目如果不用递归的话，就没办法了吗？呵呵

大家可以讨论下，不用递归怎么实现。递归的优点是代码量短，但效率往往不及迭代，递归算法一般也可以用迭代算法来实现。看看谁能用迭代算法用LISP给实现了。

Gu_xl · 发表于 2013-4-20 22:01:34

Highflybird 发表于 2013-4-20 21:28

登录/注册后可看大图

似乎这个题目如果不用递归的话，就没办法了吗？呵呵

不用递归也可以哦！
[pcode=lisp,true](defun chblkcolor (NAME COLOR / ITEMSALL OBJLIST BLOCKS OBJ OBJNAME)
  (defun itemsall (obj / l)
(vlax-for a obj (setq l (cons a l)))
(reverse l)
  )
  (setq
objlist (itemsall (vla-item (setq blocks (vla-get-blocks
         (vla-get-ActiveDocument
   (vlax-get-acad-object)
         )
      )
)
name
      )
      )
  )
  (while objlist
(setq obj    (car objlist)
   objlist (cdr objlist)
)
(if (or (= (setq objname (vla-get-ObjectName obj))
         "AcDbBlockReference"
      )
      (= objname "AcDbMInsertBlock")
)
   (setq objlist (append objlist (itemsall (vla-item blocks (vla-get-name obj)))))
   (vla-put-color obj color)
)
  )
)
;;测试
(chblkcolor (cdr (assoc 2 (entget (car (entsel))))) 5)[/pcode]

Free-Lancer · 发表于 2013-4-21 09:38:08

将块改颜色进行到底，不知道这个算法算不算迭代[pcode=lisp,true](defun chgblkcol (bnlst / bn)
  (while bnlst
(vlax-for obj
            (vla-item       (vla-get-blocks
                        (vla-get-activedocument (vlax-get-acad-object))
                     )
                     (car bnlst)
            )
   (vla-put-color obj acbyblock)
   (if (and (wcmatch (vla-get-objectname obj) "AcDbBlockReference")
            (not (assoc (setq bn (vla-get-name obj)) bnlst))
      )
      (progn
      (if (vla-get-hasattributes obj)
         (foreach x (vlax-invoke obj 'getattributes)
            (vlax-put x 'color acbyblock)
         ) ;_处理属性
      )
      (setq bnlst (cons bn (cdr bnlst))) ;_再次添加不包括的图块，每个图块仅处理一次
      )
      (setq bnlst (cdr bnlst)) ;_处理下一个图块
   )
)
  )
)
(defun c:tt (/ ss sl i e el bnlst elst)
  (if (and (setq col (acad_colordlg 4))
         (setq ss (ssget '((0 . "insert"))))
   )
(progn
   (setq sl (sslength ss)
         i  -1
   )
   (repeat sl
      (setq e          (ssname ss (setq i (1+ i)))
            el (entget e)
            bnlst (if       (not (assoc (setq bn (cdr (assoc 2 el))) bnlst))
                  (cons bn bnlst)
                  ) ;_块名列表
      )
      (if (assoc 62 el)
      (setq elst (cons e elst))
      ) ;_首层属性块
      (vlax-put (vlax-ename->vla-object e) 'color col)
      (if elst
      (foreach x elst
         (foreach y (vlax-invoke (vlax-ename->vla-object e) 'getattributes)
            (vlax-put y 'color acbyblock)
         )
      )
      )
   )
   (chgblkcol bnlst)
   ;;(vl-cmdf ".cmdf" regen)
)
  )
  (princ)
)[/pcode]

Free-Lancer · 发表于 2013-4-21 09:50:02

再补充一句，块内的 SEQEND 实体也可以有图层，这个实体无法用 ActiveX 方法获取，只能 Entnenxt 来获取并修改，某些“专业”软件会自作主张的将这个实体也赋予图层，带来的问题就是 Purge 的时候找不到实体也不能删除图层。

xyp1964 · 发表于 2013-4-21 10:07:00

(defun c:tt (/ i ss s1 pt)
(defun aaa (obj / vlst)
(defun bbb (obj / x)
(vlax-for x (vla-item (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-get-name obj)
)
(if (= (vla-get-objectname x) "AcDbBlockReference")
(bbb x)
)
(setq vlst (cons x vlst))
)
)
(bbb obj)
)
(if (and (setq s1 (car (entsel "\n选择: ")))
(equal (cdr (assoc 0 (entget s1))) "INSERT")
)
(foreach a (aaa (vlax-ename->vla-object s1))
(vla-put-color a 4) ;4为颜色号，可自定义
)
)
(command "regen")
(princ)
)

ScmTools · 发表于 2013-4-21 13:42:49

这类处理一般都是先遍历块，然后再处理

XDSoft · 发表于 2013-4-21 14:07:06

Free-Lancer 发表于 2013-4-21 09:38

登录/注册后可看大图

将块改颜色进行到底，不知道这个算法算不算迭代(defun chgblkcol (bnlst / bn)
(while bnlst
(vlax ...

判断是不是用了“递归”，如果程序中没有函数再调用自身，那就不是递归。

梦断江南 · 发表于 2013-4-22 18:28:55

翻了多年不动的箱底，发现一个，这是个通用改特性的函数。前面有一个题目是改块属性角度的，可以在这个基础上稍微修改一下，也可解。
[pcode=lisp,true](xblkp blkobj prop val) = 递归改块属性.--------ok!---By lxx 2004.11.12
参数: blkobj = vla块实体.
   prop, val = 属性，新值.
测试: ok!
(setq blk (vla-item blks (vla-get-name (vlax-ename->vla-object (car(entsel))))))
(xblkp blk 'color 3)
|;
(defun xblkp (blkobj prop val )
  (if (not *doc) (setq *doc (vla-get-activedocument (vlax-get-acad-object))))
  (if (not blks) (setq blks (vla-get-blocks *doc)))
  (vlax-for obj blkobj  ;; obj = 块内实体.
(if(= (vla-get-objectname obj) "AcDbBlockReference")
   (xblkp (vla-item blks (vla-get-name obj)) prop val)
   (vlax-put obj prop val)
)
  )
)[/pcode]

梦断江南 · 发表于 2013-4-22 18:31:50

用了lisp格式代码标志怎么没有效果？还不能edit？

adolfken · 发表于 2013-4-25 18:31:24

似乎只会用遍历

XDSoft · 发表于 2013-4-26 22:16:36

梦断江南发表于 2013-4-22 18:31

登录/注册后可看大图

用了lisp格式代码标志怎么没有效果？还不能edit？

江南，怎么理解你的话呢？

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

[研讨] 块中套块的实体修改其中的图元属性的实现

评分

评分

评分