求一个把图中所有的块都统一的移动到0图层的代码或者思路？？
求一个把图中所有的块都统一的移动到0图层的代码或者思路？？ 忘了出自哪里了。;;;运行命令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")
;(setq vlxt :vlax-true)
;(princ (vlax-property-available-p Att 'LockPosition))
;(vlax-put-property Att 'LockPosition :vlax-true)
;(vlax-put-property Att 'LockPosition vlxt)
;(princ (vlax-get-property Att 'LockPosition ))
(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)
)
)
) (Defun C:gb (/ ss)
(setvar 'cmdecho 0)
(vl-cmdf "layer" "m" "图块" "")
(ssget "X" '((0 . "INSERT")))
(Vl-cmdf "chprop" "p" "" "la" "图块" "")
)简单的移动到一个层 (xyp-SubUpd (ssget "x" '((0 . "insert"))) 8 "0")
页:
[1]