LISP 2: ;; DOI DIEM CHEN BLOCK TUYET CU MEO
;; -- Retains Insertion Point --
(defun c:CB nil (ChangeBlockInsertion nil))
;; -- Retains Block Position --
(defun c:CB nil (ChangeBlockInsertion t))
;;------------------{ Local Functions }------------------------;;
(defun ChangeBlockInsertion ( retain / *error* _StartUndo _EndUndo doc blocks oldc
SourceBlock pt undo vec name ss )
;; © Lee Mac 2010
(vl-load-com)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
blocks (vla-get-blocks doc))
(defun *error* ( msg )
(if doc (_EndUndo doc))
(if oldc (setvar 'CMDECHO oldc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)
(defun _StartUndo ( doc ) (_EndUndo doc)
(vla-StartUndoMark doc)
)
(defun _EndUndo ( doc )
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndoMark doc)
)
)
(setq oldc (getvar 'CMDECHO))
(setvar 'CMDECHO 0)
(if
(and
(setq SourceBlock
(LM:Selectif
(lambda ( x )
(eq "AcDbBlockReference"
(vla-get-ObjectName (vlax-ename->vla-object x))
)
)
entsel "\nSelect Block: "
)
)
(setq SourceBlock (vlax-ename->vla-object SourceBlock))
(setq pt (getpoint "\nSpecify New Base Point: "))
)
(progn
(_StartUndo doc)
(setq Vec (LM:ChangeBlockInsertion SourceBlock pt)
Name (LM:GetBlockName SourceBlock))
(if retain
(
(lambda ( i / ss e obj )
(setq ss (ssget "_X" (list (cons 0 "INSERT") (cons 2 Name))))
(while (setq e (ssname ss (setq i (1+ i))))
(vla-Move (setq obj (vlax-ename->vla-object e))
(vlax-3D-point '(0. 0. 0.))
(vlax-3D-point (mxv (LM:Def->Geom obj) Vec))
)
)
)
-1
)
)
(if (eq :vlax-true (vla-get-HasAttributes SourceBlock))
(vl-cmdf "_.attsync" "_N" Name)
)
(vla-regen doc acAllViewports)
(_EndUndo doc)
)
)
(setvar 'CMDECHO oldc)
(princ)
)
;;---------------=={ Change Block Insertion }==---------------;;
;; ;;
;; Changes the block definition insertion point calculated ;;
;; from a reference block and user specified point. ;;
;;------------------------------------------------------------;;
;; Author: Lee McDonnell, June 2010 ;;
;; ;;
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; SourceBlock - VLA Block Reference Object ;;
;; Pt (UCS) - New Insertion Point relative to SourceBlock ;;
;;------------------------------------------------------------;;
;; Returns: Translation Vector from mapping previous ;;
;; insertion point to new point, relative to ;;
;; block definition geometry. ;;
;;------------------------------------------------------------;;
(defun LM:ChangeBlockInsertion ( SourceBlock pt / BlockDef Mat Vector )
;; © Lee Mac 2010
(vl-load-com)
(if (and (setq BlockDef (LM:Itemp blocks (LM:GetBlockName SourceBlock)))
(setq Mat (LM:Geom->Def SourceBlock)))
(progn
(setq Vector
(mxv Mat
(mapcar '- (setq pt (trans pt 1 0)) ; UCS->WCS
(setq Insertion
(vlax-get SourceBlock 'InsertionPoint)
)
)
)
)
(vlax-for obj BlockDef
(vla-Move obj (vlax-3D-point Vector) (vlax-3D-point '(0. 0. 0.)))
)
)
)
Vector
)
;;---------------------=={ Geom->Def }==----------------------;;
;; ;;
;; Returns the Transformation Matrix for transforming Block ;;
;; Geometry to the Block Definiton. ;;
;;------------------------------------------------------------;;
;; Author: Lee McDonnell, June 2010 ;;
;; ;;
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; SourceBlock - VLA Block Reference Object ;;
;;------------------------------------------------------------;;
;; Returns: A 3x3 Transformation Matrix ;;
;;------------------------------------------------------------;;
(defun LM:Geom->Def ( SourceBlock / norm ang x y z )
;; © Lee Mac 2010
(vl-load-com)
(setq norm (vlax-get SourceBlock 'Normal)
ang (- (vla-get-rotation SourceBlock)))
(mapcar 'set '(x y z)
(mapcar
'(lambda ( prop alt )
(/ 1.
(vlax-get-property SourceBlock
(if (vlax-property-available-p SourceBlock prop) prop alt)
)
)
)
'(XEffectiveScaleFactor YEffectiveScaleFactor ZEffectiveScaleFactor)
'(XScaleFactor YScaleFactor ZScaleFactor )
)
)
(mxm
(list
(list x 0. 0.)
(list 0. y 0.)
(list 0. 0. z)
)
(mxm
(list
(list (cos ang) (sin (- ang)) 0.)
(list (sin ang) (cos ang) 0.)
(list 0. 0. 1.)
)
(mapcar '(lambda ( e ) (trans e norm 0 t)) ; OCS->WCS
'((1. 0. 0.) (0. 1. 0.) (0. 0. 1.))
)
)
)
)
;;---------------------=={ Def->Geom }==----------------------;;
;; ;;
;; Returns the Transformation Matrix for transforming Block ;;
;; Definition Geometry to a Block Reference. ;;
;;------------------------------------------------------------;;
;; Author: Lee McDonnell, June 2010 ;;
;; ;;
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; SourceBlock - VLA Block Reference Object ;;
;;------------------------------------------------------------;;
;; Returns: A 3x3 Transformation Matrix ;;
;;------------------------------------------------------------;;
(defun LM:Def->Geom ( SourceBlock / norm ang x y z )
;; © Lee Mac 2010
(vl-load-com)
(setq norm (vlax-get SourceBlock 'Normal)
ang (vla-get-rotation SourceBlock))
(mapcar 'set '(x y z)
(mapcar
'(lambda ( prop alt )
(vlax-get-property SourceBlock
(if (vlax-property-available-p SourceBlock prop) prop alt)
)
)
'(XEffectiveScaleFactor YEffectiveScaleFactor ZEffectiveScaleFactor)
'(XScaleFactor YScaleFactor ZScaleFactor )
)
)
(mxm
(mapcar '(lambda ( e ) (trans e 0 norm t)) ; WCS->OCS
'((1. 0. 0.) (0. 1. 0.) (0. 0. 1.))
)
(mxm
(list
(list (cos ang) (sin (- ang)) 0.)
(list (sin ang) (cos ang) 0.)
(list 0. 0. 1.)
)
(list
(list x 0. 0.)
(list 0. y 0.)
(list 0. 0. z)
)
)
)
)
;;-------------------=={ Get Block Name }==-------------------;;
;; ;;
;; Retrieves the Block Name as per the Block Definition ;;
;;------------------------------------------------------------;;
;; Author: Lee McDonnell, June 2010 ;;
;; ;;
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; obj - VLA Block Reference Object ;;
;;------------------------------------------------------------;;
;; Returns: Block Name [STR] ;;
;;------------------------------------------------------------;;
(defun LM:GetBlockName ( obj )
;; © Lee Mac 2010
(vlax-get-property obj
(if (vlax-property-available-p obj 'EffectiveName)
'EffectiveName 'Name
)
)
)
;;-----------------------=={ Itemp }==------------------------;;
;; ;;
;; Retrieves the item with index 'item' if present in the ;;
;; specified collection, else nil ;;
;;------------------------------------------------------------;;
;; Author: Lee McDonnell, 2010 ;;
;; ;;
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; coll - the VLA Collection Object ;;
;; item - the index of the item to be retrieved ;;
;;------------------------------------------------------------;;
;; Returns: the VLA Object at the specified index, else nil ;;
;;------------------------------------------------------------;;
(defun LM:Itemp ( coll item )
;; © Lee Mac 2010
(if
(not
(vl-catch-all-error-p
(setq item
(vl-catch-all-apply
(function vla-item) (list coll item)
)
)
)
)
item
)
)
;;---------------------=={ Select if }==----------------------;;
;; ;;
;; Continuous selection prompts until the predicate function ;;
;; foo is validated ;;
;;------------------------------------------------------------;;
;; Author: Lee McDonnell, 2010 ;;
;; ;;
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; foo - optional predicate function taking ename argument ;;
;; fun - selection function to invoke ;;
;; str - prompt string ;;
;;------------------------------------------------------------;;
;; Returns: selected entity ename if successful, else nil ;;
;;------------------------------------------------------------;;
(defun LM:Selectif ( foo fun str / e )
;; © Lee Mac 2010
(while
(progn (setq e (car (fun str)))
(cond
( (eq 'ENAME (type e))
(if (and foo (not (foo e)))
(princ "\n** Invalid Object Selected **")
)
)
)
)
)
e
)
;; Matrix x Vector ~ Vladimir Nesterovsky
(defun mxv ( mat vec )
(mapcar '(lambda ( row ) (apply '+ (mapcar '* row vec))) mat)
)
;; Matrix x Matrix ~ Vladimir Nesterovsky
(defun mxm ( m q )
(mapcar (function (lambda ( r ) (mxv (trp q) r))) m)
)
;; Matrix Transpose ~ Doug Wilson
(defun trp ( m )
(apply 'mapcar (cons 'list m))
)
......when copy lisp 1 & 2 into 1 file lisp, i have a error...
THANKS
