[求助]求图块改颜色的程序

liminnet · 发表于 2009-3-27 17:31:00

提示: 作者被禁止或删除内容自动屏蔽

caoyin · 发表于 2009-3-27 17:35:00

本帖啊，置顶的帖子因为使用论坛的代码自动着色功能而出错

54256 · 发表于 2009-3-27 19:39:00

caoyin大哥，麻烦说下６楼和７楼的区别，另外６楼的我加载就错误

highflybir · 发表于 2009-3-28 00:01:00

希望这个程序是你所需要的。

caoyin · 发表于 2009-3-28 10:52:00

54256发表于2009-3-27 19:39:00caoyin大哥，麻烦说下６楼和７楼的区别，另外６楼的我加载就错误

不好意思，多了一个闭括号

区别不大，一个是修改所有对象，一个是修改块的

jxphklibin · 发表于 2009-3-28 11:14:00

highflybir发表于2009-3-28 0:01:0046698希望这个程序是你所需要的。

程序有点问题，差冻结的不能处理

隐藏的可以处理，就差冻结

执行命令的时候，选择图块时，直接在命令行输入 all 选择全部

jxphklibin · 发表于 2009-3-28 14:43:00

本帖最后由作者于 2009-3-28 14:45:19 编辑

增加一个子函数，对付冻结的图层：

;; 解除图层冻结 BY 木子CAD 小李子 2009-3-28
(defun c:test (/ *app *doc *blk)
(setq *App (vlax-get-acad-object))
(setq *Doc (vla-get-ActiveDocument *APP))
(vlax-for n (vla-get-layers *DOC)
(if (/= (strcase (vla-get-name n))
(strcase (getvar "clayer"))
)
(vla-put-Freeze n :vlax-false) ;(vlax-dump-object n t)
)
)
(command "regen") ;(vla-regen)
)
(defun C:LayUnFrz (/ acadDocument theLayers)
(vl-load-com)
(setq acadDocument (vla-get-activedocument (vlax-get-acad-object)))
(setq theLayers (vla-get-layers acadDocument))
(vlax-for item theLayers
(if (/= (strcase (vla-get-name item))
(strcase (getvar "clayer"))
)
(vlax-put-property item "Freeze" ':vlax-false)
)
)
(princ)
)

jxphklibin · 发表于 2009-3-28 15:24:00

最后修改的程序，增加图层冻结情况的处理，完整程序代码如下：

;;;运行命令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)
)
)
)

;;;运行命令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)
    )
  )
)

haiyunzhou · 发表于 2011-11-19 01:38:21

改块的程序非常棒要是改块的时候不跳出来选择颜色对话框就好了

【KAIXIN】 · 发表于 2012-5-6 00:11:34

caoyin 发表于 2009-3-27 17:04
;;改块的(defun c:ChBlkColor (/ ChBlkColor SS blks I Obj BnLst)  (defun ChBlkColor (Blks Obj Col ...

改块子对象颜色好实现吗？

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

[求助]求图块改颜色的程序

本帖子中包含更多资源

本帖子中包含更多资源

点评

liminnet liminnet 当前离线积分 9742 明经币个注册时间 2007-8-22 在线时间小时威望金钱个贡献激情	发表于 2009-3-27 17:31:00 \| 显示全部楼层提示: 作者被禁止或删除内容自动屏蔽

	回复支持反对使用道具举报显身卡