社区 › AutoLISP/Visual LISP 编程技术 › 【飞鸟集】再谈块的重新定义和全部实体改颜色

highflybir 发表于 2007-4-3 18:07:00

【飞鸟集】再谈块的重新定义和全部实体改颜色

以前曾经发了一个能把CAD中所有实体（包括块和嵌套块中所有单独实体）颜色都改颜色的程序.
其中龙龙仔版主提出:对于已经插入的属性无效。后来没有深入下去修改程序。
今天在autodesk讨论组中又看到了这个话题。其中一个程序的思路跟我的思路很相似，且能对属性块有效，下面把它贴出来。
(defun c:CCC ()
(vl-load-com)
(vlax-for Blk (vla-get-Blocks
    (vla-get-ActiveDocument
      (vlax-get-Acad-Object)
    )
)
    (vlax-for Obj Blk
      (vla-put-Color Obj 256)    ;256随层
      (if (= (vla-get-ObjectName Obj) "AcDbBlockReference")
(foreach Att (vlax-invoke Obj 'GetAttributes)
   (vla-put-Color Att 256);256随层
)
      )
    )
)
)
Gilles Chanteau在这个讨论中发了一个很好的程序，能实现对块内的实体全部修改的程序。
这个程序的功能是:
对图块内所有实体，包括嵌套块，单个图元全部改变其属性（图层，颜色，线型，线宽）
命令为: edit_bloc
这是其加载后的效果：

下面是其改变后的效果：

程序的源文件:

对话框文件：

编译后的文件:

wsj249201 发表于 2012-2-28 19:14:26

raimo 发表于 2011-8-27 07:53 static/image/common/back.gif
改底图比较好的小工具...
能不能出个简单版的lsp..不要对话框..只需要直接将所需要的块变成一个颜色(不变层 ...

试试这个，好像可以的

;;;运行命令test
(defun c:test (/ i ent sel obj lst LayLst)
   (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 (vlax-ename->vla-object ent))
       (setq lst (entget ent))
       (change-color obj)
       (setq i (1+ i))
   )
   (princ "\n你没有选择物体!")
   )
   (Restore_Layer_Status LayLst)
   (princ)
)
;;;主要函数
(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)
   )
   )
)

寒潮大冬瓜 发表于 2024-8-25 23:27:46

很好→很棒！很好~很棒！！很好……很棒！！！

tender138 发表于 2024-7-16 09:00:11

多谢大师，留个脚印慢慢学习

kinglzk2000 发表于 2011-6-29 08:00:55

好   ，感谢分享挺好使

外面下雪了 发表于 2011-6-29 09:00:23

这个好啊，修改底图特好使

caoyin 发表于 2011-6-29 09:07:51

很早以前发过类似的东西，结论是除了MLINE不能修改

xigemapenis 发表于 2011-8-27 04:58:30

raimo 发表于 2011-8-27 07:53:26

改底图比较好的小工具...
能不能出个简单版的lsp..不要对话框..只需要直接将所需要的块变成一个颜色(不变层,只改颜色)

zhuangxu_521 发表于 2011-8-29 16:12:48

没看明白应该怎么用

xotoo 发表于 2011-8-31 16:05:13

搞个中文版吧

faith66 发表于 2012-2-28 16:38:53

真是精辟

查看完整版本: 【飞鸟集】再谈块的重新定义和全部实体改颜色