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

XDSoft

刚看到有朋友发帖讨论图元归层问题涉及到块内实体和块内套块的实体统一修改的问题，发个测试图上来。

二楼的图说明下：

1、整体是个块
2、黄色的两个三角形是一个块
3、红色的2个园和 黄色的块又是一个块。

也就是整体这个块由：

1、一条白色的线+ 块1 组成
    1）块1由两个红色的圆+块2组成
         a)块2有两个黄色的多段线组成。

现在发布悬赏贴，如何把块中所有的实体的颜色变成蓝色。希望大家用各种方法实现，包括纯LISP,VLISP等等。

程序代码最简捷的奖获得50个D豆（D豆我自身出）。其他每个能实现目的的代码都将获得30D豆（由版主奖励评分获得），参与讨论的每个朋友也将获得奖励。

时间截止到2013年4月26日0点整

二楼RAR附件是测试的DWG图形。

XDSoft

附图DWG下载这个。

炫翔

先来个最简单的，点选模式，
[pcode=lisp,true];改变对象颜色，包括图块内的子对象
(defun c:xx( / c1 c2 c3 e1 e2 e3)
  (setq e1 (nentsel"\n-->请点选对象"))
  (if e1
    (progn
      (setq c1 (GETINT "颜色号:"))
      (setq c2 (cons 62 c1))
      (setq e2 (entget (car e1)))
      (setq c3 (assoc 62 e2))
      (if c3
        (setq e2 (subst c2 c3 e2))
        (setq e2 (cons c2 e2))
      )
      (entmod e2)
      (setq e3 (car (cadddr e1)))
      (if e3
        (entupd e3)
      )
    )
    (princ "\n未选取到对象。")
  )
)
[/pcode]

夜来风语声

XDSoft 发表于 2013-4-20 16:28

                               
登录/注册后可看大图

附图DWG下载这个。

[pcode=lisp,true](defun c:tt (/ chBlockColor e el)
  (vl-load-com)
  (defun chBlockColor (blockname color / obj objname)
    (vlax-for obj
              (vla-item        (vla-get-blocks
                          (vla-get-ActiveDocument (vlax-get-acad-object))
                        )
                        blockname
              )
      (if (or (= (setq objname (vla-get-ObjectName obj))
                 "AcDbBlockReference"
              )
              (= objname "AcDbMInsertBlock")
          )
        (chBlockColor (vla-get-name obj) color)
        (vla-put-color obj color)
      )
    )
  )
  (setq e (car (entsel "\n选择块:")))
  (if (= "INSERT" (cdr (assoc 0 (setq el (entget e)))))
    (chBlockColor (cdr (assoc 2 el)) 5)
  )
  (command "regen") ;_ 重显图块
  (princ)
)[/pcode]

笑2笑

[pcode=lisp,true]
(defun c:tt (/ i laylst sel ent obj lst)
  (setq *app (vlax-get-acad-object))
  (setq *doc (vla-get-activedocument *app))
  (setq *blk (vla-get-blocks *doc))
  (setq i 0)
  (setq laylst (get_layer_status *doc))
  (unlock_all_layers *doc)
  (unfreeze_all_layers *doc)
  (if (setq sel (ssget '((0 . "INSERT"))))
    (repeat (sslength sel)
      (setq ent (ssname sel i))
      (setq obj (xx-e2o ent))
      (setq lst (entget ent))
      (change-color obj)
      (setq i (1+ i))
    )
    (princ "\n你没有选择物体!")
  )
  (restore_layer_status laylst)
  (xx-comb)
)

;;;主要函数
(defun change-color (obj / name blks)
  (vla-put-color obj acbylayer)               ; 要加出错处理，因为有的可能被锁定
  (if (or
        (= (vla-get-objectname obj) "AcDbBlockReference")
        (= (vla-get-objectname obj) "AcDbMInsertBlock")
      )
    (progn
      (foreach att (vlax-invoke obj 'getattributes)
        (vla-put-layer att "0")
        (vla-put-color att acbylayer)  ; 这一行用于处理属性随层
      )
      (setq name (vla-get-name obj))   ; 取得块名
      (setq blks (vla-item *blk name))
      (vlax-for n blks (change-color n)        ; 递归进去，用于处理嵌套
      )
    )
    (vla-put-layer obj "0")               ; 如果不改为0层，则有的可能不变色
  )
)

;;; 以下函数仅仅为防止出错用
;;; 得到图层状态
(defun Get_Layer_Status (*DOC / V_LIST L_LIST C_LIST T_LIST W_LIST)
  (vlax-for n (vla-get-layers *DOC)
    (setq V_List (cons (cons n (vla-get-LayerOn n)) V_List)
   L_List (cons (cons n (vla-get-Lock n)) L_List)
   C_List (cons (cons n (vla-get-TrueColor n)) C_List)
   T_List (cons (cons n (vla-get-Linetype n)) T_List)
   W_List (cons (cons n (vla-get-LineWeight n)) W_List)
   F_List (cons (cons n (vla-get-Freeze n)) F_List)
    )
  )
  (List V_List L_List C_List T_List W_List F_List)
)
;;;恢复图层状态
(defun restore_layer_status (laylst)
  (mapcar
    (function (lambda (x y)
                (foreach n x
                  (if (/= (strcase (setq name (vla-get-name (car n))))
                          (strcase (getvar "clayer"))
                      )                       ; 非当前层
                    (vlax-put-property (car n) y (cdr n)) ; 对于当前层
                    (if (/= y "Freeze")        ; 排除冻结操作，以防出错
                      (vlax-put-property (car n) y (cdr n))
                    )
                  )
                )
              )
    )
    laylst
    (list "Layeron" "Lock" "TrueColor" "LineType" "LineWeight" "Freeze")
  )
)

;;;解锁所有图层
(defun UnLock_All_Layers (*DOC)
  (vlax-for n (vla-get-layers *DOC)
    (vla-put-lock n :vlax-false)
  )
)
;;;解冻所有图层
(defun UnFreeze_All_Layers (*DOC)
  (vlax-for n (vla-get-layers *DOC)
    (if (/= (strcase (vla-get-name n))
     (strcase (getvar "clayer"))
)
      (vla-put-Freeze n :vlax-false)
    )
  )
)[/pcode]

处处问题鸟

[pcode=lisp,true](defun c:tt (/ cbc e)
  (defun cbc (e c)
    (setq e (tblobjname "block" (cdr (assoc 2 (entget e)))))
    (while (setq e (entnext e))
      (if (= "INSERT" (cdr (assoc 0 (setq el (entget e)))))
        (cbc e c)
        (if (setq a (assoc 62 el))
          (entmod (subst (cons 62 c) a el))
          (entmod (append en (list (cons 62 c))))
        )
      )
    )
  )
  (if
    (and
      (setq e (car (entsel "\n选择块:")))
      (= "INSERT" (cdr (assoc 0 (entget e))))
    )
     (progn
       (cbc e 5)
       (entupd e)
     )
  )
  (princ)
)[/pcode]

XDSoft

朋友们也太热心了吧，还没发布1个小时，上来这么些程序，都是有备之人啊。

大家可以讨论讨论里面的技巧啊，算法啊。

炫翔

应该都是以前的程序，我个人的思路是;遍历块改色，欢迎大家热烈参与

wowan1314

块的处理还没学习呢！！:'(:'(

处处问题鸟

不管用哪种方法，基本思路就是递归调用！

Free-Lancer

ByBlock 的好处是可以Insert指定不同颜色
[pcode=lisp,true](defun chgblkbyblock (bn /)
  (vlax-for obj
     (vla-item (vla-get-blocks
                     (vla-get-activedocument (vlax-get-acad-object))
        )
        bn
     )
    (vla-put-color obj acByblock)
    (if (wcmatch (vla-get-objectname obj) "AcDbBlockReference")
      (chgblkbyblock (vla-get-name obj))
    ) ;_递归处理
  )
)
(defun c:tt (/ ss sl i e el)
  (while (setq ss (ssget '((0 . "Insert"))))
    (setq sl (sslength ss)
             i  -1
    )
    (repeat sl
      (setq e  (ssname ss (setq i (1+ i)))
               el (entget e)
      )
      (chgblkbyblock (cdr (assoc 2 el)))
      (entmod (if (assoc 62 el)
                      (subst '(62 . 4)
                              (assoc 62 el)
                              el
                    )
                   (append el '((62 . 4)))
       ) ;_修改顶层颜色
      )
    )
  )
  (princ)
)[/pcode]

xyp1964

[pcode=lisp,true]
;; 先给段自定义函数
(defun c:tt (/ i ss s1 pt)  (if (and (setq s1 (car (entsel "\n选择: ")))
           (equal (cdr (assoc 0 (entget s1))) "INSERT")
      )
    (foreach a (xyp-Block-ObjList (xyp-e2o s1))
      (setq b (cadr a))
      (vla-put-color b 4)
    )
  )
  (xyp-regen)
  (princ)
)[/pcode]

xyp1964

遍历块（包括嵌套块）中的所有实体，现成表，然后逐个用vla-put-color函数改颜色。

XDSoft

xyp1964 发表于 2013-4-20 20:02

                               
登录/注册后可看大图

;; 先给段自定义函数

:) XYP, 把xyp-Block-Object 函数贴出来一起。要不无法判断最简洁代码。

wowan1314

找了下收藏夹！ 发现确实收藏了个函数，感谢原作者
;;;***********************************************************
;;;  获取图块内的所有非图块对象(含嵌套块中的)名称 函数 ----BY 无名氏
;;;***********************************************************
(defun ayGetAllEntInBLK (BlkEntName / xBlkName xBlkDef entName1 entType entNameList)
  (setq xBlkName (cdr (assoc 2 (entget BlkEntName))))
        (setq xBlkDef (tblobjname "Block" xBlkName))
  (while (setq entName1 (entnext xBlkDef))
    (setq entType (cdr (assoc 0 (entget entName1))))
    (if (= entType "INSERT")
      (setq entNameList (cons entName1 entNameList)
             entNameList (append (ayGetAllEntInBLK entName1) entNameList))
      (setq entNameList (cons entName1 entNameList))
    );end_if
    (setq xBlkDef entName1)
  );end_while
  entNameList
);end_defun

估计还是VL函数简洁~