明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 8504|回复: 18

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

    [复制链接]
发表于 2007-4-3 18:07 | 显示全部楼层 |阅读模式
以前曾经发了一个能把CAD中所有实体(包括块和嵌套块中所有单独实体)颜色都改颜色的程序.
其中龙龙仔版主提出:对于已经插入的属性无效。后来没有深入下去修改程序。
今天在autodesk讨论组中又看到了这个话题。其中一个程序的思路跟我的思路很相似,且能对属性块有效,下面把它贴出来。

  1. (defun c:CCC ()
  2.   (vl-load-com)
  3.   (vlax-for Blk (vla-get-Blocks
  4.     (vla-get-ActiveDocument
  5.       (vlax-get-Acad-Object)
  6.     )
  7.   )
  8.     (vlax-for Obj Blk
  9.       (vla-put-Color Obj 256)    ;256随层
  10.       (if (= (vla-get-ObjectName Obj) "AcDbBlockReference")
  11. (foreach Att (vlax-invoke Obj 'GetAttributes)
  12.    (vla-put-Color Att 256);256随层
  13. )
  14.       )
  15.     )
  16.   )
  17. )
Gilles Chanteau在这个讨论中发了一个很好的程序,能实现对块内的实体全部修改的程序。
这个程序的功能是:
对图块内所有实体,包括嵌套块,单个图元全部改变其属性(图层,颜色,线型,线宽)
命令为: edit_bloc
这是其加载后的效果:

下面是其改变后的效果:

程序的源文件:

对话框文件:

编译后的文件:

本帖子中包含更多资源

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

x

评分

参与人数 1明经币 +1 收起 理由
tigcat + 1 很给力!

查看全部评分

"觉得好,就打赏"
还没有人打赏,支持一下

本帖被以下淘专辑推荐:

发表于 2012-2-28 19:14 | 显示全部楼层
raimo 发表于 2011-8-27 07:53
改底图比较好的小工具...
能不能出个简单版的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)
     )
   )
)

点评

很好用很贴心  发表于 2016-11-8 14:33
在AutoCAD2014、AutoCAD2016环境下,载入该lisp文件,报“语法错误”,不知道是怎么回事?  发表于 2015-6-25 11:40

评分

参与人数 1明经币 +1 收起 理由
自贡黄明儒 + 1 很给力!

查看全部评分

回复 支持 1 反对 0

使用道具 举报

发表于 2020-10-7 16:56 | 显示全部楼层
最近在研究块留个脚印
发表于 2022-3-1 08:38 | 显示全部楼层
感谢分享,一直在找
发表于 2011-6-29 08:00 | 显示全部楼层
好   ,感谢分享  挺好使
发表于 2011-6-29 09:00 | 显示全部楼层
这个好啊,修改底图特好使
发表于 2011-6-29 09:07 | 显示全部楼层
很早以前发过类似的东西,结论是除了MLINE不能修改
发表于 2011-8-27 04:58 | 显示全部楼层
发表于 2011-8-27 07:53 | 显示全部楼层
改底图比较好的小工具...
能不能出个简单版的lsp..不要对话框..只需要直接将所需要的块变成一个颜色(不变层,只改颜色)
发表于 2011-8-29 16:12 | 显示全部楼层
没看明白应该怎么用
发表于 2011-8-31 16:05 | 显示全部楼层
搞个中文版吧
发表于 2012-2-28 16:38 | 显示全部楼层
真是精辟
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-3-28 19:32 , Processed in 0.204541 second(s), 32 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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