求一个把图中所有的块都统一的移动到0图层的代码或者思路？？

bingshuier · 发表于 2014-7-26 11:25:31

edata · 发表于 2014-7-26 12:14:53

忘了出自哪里了。

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

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

1993063 · 发表于 2014-7-26 15:45:04

(Defun C:gb (/ ss)
  (setvar 'cmdecho 0)
  (vl-cmdf "layer" "m" "图块" "")
  (ssget "X" '((0 . "INSERT")))
  (Vl-cmdf "chprop" "p" "" "la" "图块" "")
)

简单的移动到一个层

xyp1964 · 发表于 2014-7-26 16:50:31

(xyp-SubUpd (ssget "x" '((0 . "insert"))) 8 "0")

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

[提问] 求一个把图中所有的块都统一的移动到0图层的代码或者思路？？

浏览过的版块