- 积分
- 63995
- 明经币
- 个
- 注册时间
- 2010-5-9
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
发表于 2023-3-14 16:40:30
|
显示全部楼层
;;--------------------=={ Move to Top }==---------------------;;
;; ;;
;; Moves a set of objects to the top of the draw order. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2012 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; doc - VLA Document Object ;;
;; objs - Selection Set or List of Objects with same owner ;;
;;------------------------------------------------------------;;
;; Returns: T if successful, else nil ;;
;;------------------------------------------------------------;;
(defun LM:MovetoTop ( doc objs / tab )
(if
(and objs
(or
(listp objs)
(setq objs (LM:ss->vla objs))
)
(setq tab (LM:SortentsTable (LM:GetOwner doc (car objs))))
)
(not (vla-movetotop tab (LM:SafearrayVariant vlax-vbobject objs)))
)
)
;;------------------=={ Move to Bottom }==--------------------;;
;; ;;
;; Moves a set of objects to the bottom of the draw order. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2012 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; doc - VLA Document Object ;;
;; objs - Selection Set or List of Objects with same owner ;;
;;------------------------------------------------------------;;
;; Returns: T if successful, else nil ;;
;;------------------------------------------------------------;;
(defun LM:MovetoBottom ( doc objs / tab )
(if
(and objs
(or
(listp objs)
(setq objs (LM:ss->vla objs))
)
(setq tab (LM:SortentsTable (LM:GetOwner doc (car objs))))
)
(not (vla-movetobottom tab (LM:SafearrayVariant vlax-vbobject objs)))
)
)
;;---------------------=={ Move Above }==---------------------;;
;; ;;
;; Moves a set of objects above a supplied object. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2012 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; doc - VLA Document Object ;;
;; objs - Selection Set or List of Objects with same owner ;;
;; obj - VLA Object above which to move objects ;;
;;------------------------------------------------------------;;
;; Returns: T if successful, else nil ;;
;;------------------------------------------------------------;;
(defun LM:MoveAbove ( doc objs obj / tab )
(if
(and objs
(or
(listp objs)
(setq objs (LM:ss->vla objs))
)
(setq tab (LM:SortentsTable (LM:GetOwner doc (car objs))))
)
(not (vla-moveabove tab (LM:SafearrayVariant vlax-vbobject objs) obj))
)
)
;;---------------------=={ Move Below }==---------------------;;
;; ;;
;; Moves a set of objects below a supplied object. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2012 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; doc - VLA Document Object ;;
;; objs - Selection Set or List of Objects with same owner ;;
;; obj - VLA Object below which to move objects. ;;
;;------------------------------------------------------------;;
;; Returns: T if successful, else nil ;;
;;------------------------------------------------------------;;
(defun LM:MoveBelow ( doc objs obj / tab )
(if
(and objs
(or
(listp objs)
(setq objs (LM:ss->vla objs))
)
(setq tab (LM:SortentsTable (LM:GetOwner doc (car objs))))
)
(not (vla-movebelow tab (LM:SafearrayVariant vlax-vbobject objs) obj))
)
)
;;---------------------=={ Swap Order }==---------------------;;
;; ;;
;; Swaps the draw order of two objects (may require regen). ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2012 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; doc - VLA Document Object ;;
;; obj1,obj2 - VLA Objects to swap ;;
;;------------------------------------------------------------;;
;; Returns: T if successful, else nil ;;
;;------------------------------------------------------------;;
(defun LM:SwapOrder ( doc obj1 obj2 / tab )
(if (setq tab (LM:SortentsTable (LM:GetOwner doc obj1)))
(not (vla-swaporder tab obj1 obj2))
)
)
;;---------------------=={ Get Owner }==----------------------;;
;; ;;
;; Returns the Owner Object of the supplied VLA Object. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2012 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; obj - VLA Object for which to return owner ;;
;;------------------------------------------------------------;;
;; Returns: Owner Object of supplied VLA Object, else nil ;;
;;------------------------------------------------------------;;
(defun LM:GetOwner ( doc obj )
(if
(and
(vlax-property-available-p obj 'ownerid32)
(vlax-method-applicable-p doc 'objectidtoobject32)
)
(vla-objectidtoobject32 doc (vla-get-ownerid32 obj))
(vla-objectidtoobject doc (vla-get-ownerid obj))
)
)
;;------------------=={ Sortents Table }==--------------------;;
;; ;;
;; Retrieves the Sortents Table object. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2012 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; obj - VLA Block Container Object ;;
;;------------------------------------------------------------;;
;; Returns: Sortents Table Object, else nil ;;
;;------------------------------------------------------------;;
(defun LM:SortentsTable ( obj / dic )
(cond
( (LM:CatchApply 'vla-item
(list (setq dic (vla-getextensiondictionary obj)) "ACAD_SORTENTS")
)
)
( (LM:CatchApply 'vla-addobject (list dic "ACAD_SORTENTS" "AcDbSortentsTable")))
)
)
;;-----------------=={ SelectionSet -> VLA }==----------------;;
;; ;;
;; Converts a SelectionSet to a list of VLA Objects ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2012 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; ss - Valid SelectionSet (Pickset) ;;
;;------------------------------------------------------------;;
;; Returns: List of VLA Objects ;;
;;------------------------------------------------------------;;
(defun LM:ss->vla ( ss / i l )
(if (eq 'pickset (type ss))
(repeat (setq i (sslength ss))
(setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
)
)
)
;;---------------------=={ Catch Apply }==--------------------;;
;; ;;
;; Applies a function to a list of arguments and catches ;;
;; an exception. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2012 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; _function - function to be applied ;;
;; _params - list of arguments to be supplied to function ;;
;;------------------------------------------------------------;;
;; Returns: Result of function, else nil if exception ;;
;;------------------------------------------------------------;;
(defun LM:CatchApply ( _function _params / result )
(if (not (vl-catch-all-error-p (setq result (vl-catch-all-apply _function _params))))
result
)
)
;;------------------=={ Safearray Variant }==-----------------;;
;; ;;
;; Creates a Safearray Variant of a specified data type ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2012 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; datatype - variant type enum (eg vlax-vbDouble) ;;
;; data - list of static type data ;;
;;------------------------------------------------------------;;
;; Returns: VLA Variant Object of type specified ;;
;;------------------------------------------------------------;;
(defun LM:SafearrayVariant ( datatype data )
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray datatype (cons 0 (1- (length data))))
data
)
)
)
(vl-load-com)
(princ)
;;The following program will move the selected objects to the top of the draw order.
(defun c:top (/)
(LM:MovetoTop (cond (acdoc)
((setq acdoc (vla-get-activedocument (vlax-get-acad-object))))
)
(ssget
(list
(cons 410
(if (= 1 (getvar 'cvport))
(getvar 'ctab)
"Model"
)
)
)
)
)
(princ)
)
;;The following program will move the selected objects to the bottom of the draw order.
(defun c:bottom (/)
(LM:MovetoBottom (cond (acdoc)
((setq acdoc (vla-get-activedocument (vlax-get-acad-object))))
)
(ssget
(list
(cons 410
(if (= 1 (getvar 'cvport))
(getvar 'ctab)
"Model"
)
)
)
)
)
(princ)
)
;;The following program will move the selected objects above the draw order of the subsequently selected object.
(defun c:above (/ ss en)
(if
(and
(setq ss
(ssget
(list
(cons 410
(if (= 1 (getvar 'cvport))
(getvar 'ctab)
"Model"
)
)
)
)
)
(setq en (car (entsel "\nSelect Object to Move Selection Above: ")))
)
(LM:MoveAbove
(cond (acdoc)
((setq acdoc (vla-get-activedocument (vlax-get-acad-object))))
)
ss
(vlax-ename->vla-object en)
)
)
(princ)
)
;;The following program will move the selected objects below the draw order of the subsequently selected object.
(defun c:below (/ ss en)
(if
(and
(setq ss
(ssget
(list
(cons 410
(if (= 1 (getvar 'cvport))
(getvar 'ctab)
"Model"
)
)
)
)
)
(setq en (car (entsel "\nSelect Object to Move Selection Below: ")))
)
(LM:MoveBelow
(cond (acdoc)
((setq acdoc (vla-get-activedocument (vlax-get-acad-object))))
)
ss
(vlax-ename->vla-object en)
)
)
(princ)
)
;;The following program will swap the draw order of the two selected objects; this operation requires a regen to take effect.
(defun c:swap (/ e1 e2)
(if
(and
(setq e1 (car (entsel "\nSelect First Object: ")))
(setq e2 (car (entsel "\nSelect Object to Swap With: ")))
)
(progn
(LM:SwapOrder
(cond (acdoc)
((setq acdoc (vla-get-activedocument (vlax-get-acad-object))))
)
(vlax-ename->vla-object e1)
(vlax-ename->vla-object e2)
)
(vla-regen acdoc acactiveviewport)
)
)
(princ)
)
;;The following program will move all objects residing on the layer of a selected object to the top of the draw order.
(defun c:layertop (/ en)
(if (setq en (car (entsel "\nSelect Object on Layer to Move to Top: ")))
(LM:MovetoTop (cond (acdoc)
((setq acdoc (vla-get-activedocument (vlax-get-acad-object))))
)
(ssget "_X"
(list
(assoc 8 (entget en))
(cons 410
(if (= 1 (getvar 'cvport))
(getvar 'ctab)
"Model"
)
)
)
)
)
)
(princ)
)
;;The following program will move all Hatch objects to the bottom of the draw order.
(defun c:hatchbottom (/)
(LM:MovetoBottom (cond (acdoc)
((setq acdoc (vla-get-activedocument (vlax-get-acad-object))))
)
(ssget "_X"
(list
'(0 . "HATCH")
(cons 410
(if (= 1 (getvar 'cvport))
(getvar 'ctab)
"Model"
)
)
)
)
)
(princ)
)
|
|
[复制链接]
置顶卡
变色卡
显身卡
楼主