;; Retains Xref Reference Position
(defun c:cxpr ( / ss entlst p pentlst scfx scfy scfz bp f )
(setvar "xloadctl" 0)
(command "-layer" "u" "*" "")
(command "_.UCS" "_W")
(command "-overkill" "all" "" "")
(prompt "\nSelect Xref entities to process changing insertion points to WCS origin while retaining their position...")
(setq ss (ssget '((0 . "INSERT"))))
(setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(foreach ent entlst
(if (eq (vla-get-isxref (vla-item (vla-get-blocks (LM:acdoc)) (LM:blockname (vlax-ename->vla-object ent)))) :vlax-true)
(progn
(setq scfx (vla-get-xscalefactor (vlax-ename->vla-object ent)))
(setq scfy (vla-get-yscalefactor (vlax-ename->vla-object ent)))
(setq scfz (vla-get-zscalefactor (vlax-ename->vla-object ent)))
(command "_.UCS" "_E" ent)
(setq bp (trans '(0.0 0.0 0.0) 0 1))
(setq p (mapcar '- (list (/ (car bp) scfx) (/ (cadr bp) scfy) (/ (caddr bp) scfz))))
(setq bp (trans bp 1 0))
(command "_.UCS" "_P")
(LM:changeblockbasepoint t ent (mapcar '- bp (list (/ (car bp) scfx) (/ (cadr bp) scfy) (/ (caddr bp) scfz))))
(setq pentlst (cons (cons p ent) pentlst))
(vla-move (vlax-ename->vla-object ent) (vlax-3d-point (trans (cdr (assoc 10 (entget ent))) ent 0)) (vlax-3d-point '(0.0 0.0 0.0)))
)
)
)
(setq f (open "c:/scr.scr" "w"))
(write-line "_.QSAVE" f)
(foreach pent pentlst
(write-line "_.OPEN" f)
(write-line (strcat "\"" (findfile (vla-get-path (vlax-ename->vla-object (cdr pent)))) "\"") f)
(write-line "_.-LAYER" f)
(write-line "T" f)
(write-line "*" f)
(write-line "U" f)
(write-line "*" f)
(write-line "ON" f)
(write-line "*" f)
(write-line "" f)
(write-line "_.MOVE" f)
(write-line "ALL" f)
(write-line "" f)
(write-line "0,0,0" f)
(write-line (strcat (rtos (caar pent) 2 50) "," (rtos (cadar pent) 2 50) "," (rtos (caddar pent) 2 50)) f)
(write-line "_.LAYERP" f)
(write-line "_.QSAVE" f)
)
(write-line "_.CLOSEALL" f)
(close f)
(princ "After reopening master DWG, type (vl-file-delete \"c:/scr.scr\")")
(command "_.SCRIPT" "c:/scr.scr")
(princ)
)

;;----------------------------------------------------------------------;;

(defun LM:changeblockbasepoint ( flg ent nbp / *error* bln cmd lck mat vec )

(defun *error* ( msg )
(foreach lay lck (vla-put-lock lay :vlax-true))
(if (= 'int (type cmd)) (setvar 'cmdecho cmd))
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)

(if (and (= 'ename (type ent)) nbp)
(progn
(setq mat (car (revrefgeom ent))
vec (mxv mat (mapcar '- (trans nbp 1 0) (trans (cdr (assoc 10 (entget ent))) ent 0)))
bln (LM:blockname (vlax-ename->vla-object ent))
)
(LM:startundo (LM:acdoc))
(vlax-for lay (vla-get-layers (LM:acdoc))
(if (= :vlax-true (vla-get-lock lay))
(progn
(vla-put-lock lay :vlax-false)
(setq lck (cons lay lck))
)
)
)
(vlax-for obj (vla-item (vla-get-blocks (LM:acdoc)) bln)
(vlax-invoke obj 'move vec '(0.0 0.0 0.0))
)
(if flg
(vlax-for blk (vla-get-blocks (LM:acdoc))
(if (= :vlax-false (vla-get-isxref blk))
(vlax-for obj blk
(if
(and
(= "AcDbBlockReference" (vla-get-objectname obj))
(= bln (LM:blockname obj))
(vlax-write-enabled-p obj)
)
(vlax-invoke obj 'move '(0.0 0.0 0.0) (mxv (car (refgeom (vlax-vla-object->ename obj))) vec))
)
)
)
)
)
(if (= 1 (cdr (assoc 66 (entget ent))))
(progn
(setq cmd (getvar 'cmdecho))
(setvar 'cmdecho 0)
(vl-cmdf "_.attsync" "_N" bln)
(setvar 'cmdecho cmd)
)
)
(foreach lay lck (vla-put-lock lay :vlax-true))
(vla-regen (LM:acdoc) acallviewports)
(LM:endundo (LM:acdoc))
)
)
(princ)
)

;; RefGeom (gile)
;; Returns a list whose first item is a 3x3 transformation matrix and
;; second item the object insertion point in its parent (xref, block or space)

(defun refgeom ( ent / ang enx mat ocs )
(setq enx (entget ent)
ang (cdr (assoc 050 enx))
ocs (cdr (assoc 210 enx))
)
(list
(setq mat
(mxm
(mapcar '(lambda ( v ) (trans v 0 ocs t))
'(
(1.0 0.0 0.0)
(0.0 1.0 0.0)
(0.0 0.0 1.0)
)
)
(mxm
(list
(list (cos ang) (- (sin ang)) 0.0)
(list (sin ang) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
(list
(list (cdr (assoc 41 enx)) 0.0 0.0)
(list 0.0 (cdr (assoc 42 enx)) 0.0)
(list 0.0 0.0 (cdr (assoc 43 enx)))
)
)
)
)
(mapcar '- (trans (cdr (assoc 10 enx)) ocs 0)
(mxv mat (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx))))))
)
)
)

;; RevRefGeom (gile)
;; The inverse of RefGeom

(defun revrefgeom ( ent / ang enx mat ocs )
(setq enx (entget ent)
ang (cdr (assoc 050 enx))
ocs (cdr (assoc 210 enx))
)
(list
(setq mat
(mxm
(list
(list (/ 1.0 (cdr (assoc 41 enx))) 0.0 0.0)
(list 0.0 (/ 1.0 (cdr (assoc 42 enx))) 0.0)
(list 0.0 0.0 (/ 1.0 (cdr (assoc 43 enx))))
)
(mxm
(list
(list (cos ang) (sin ang) 0.0)
(list (- (sin ang)) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
(mapcar '(lambda ( v ) (trans v ocs 0 t))
'(
(1.0 0.0 0.0)
(0.0 1.0 0.0)
(0.0 0.0 1.0)
)
)
)
)
)
(mapcar '- (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx)))))
(mxv mat (trans (cdr (assoc 10 enx)) ocs 0))
)
)
)

;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n

(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)

;; Matrix x Matrix - Vladimir Nesterovsky
;; Args: m,n - nxn matrices

(defun mxm ( m n )
((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)

;; Matrix Transpose - Doug Wilson
;; Args: m - nxn matrix

(defun trp ( m )
(apply 'mapcar (cons 'list m))
)

;; Block Name - Lee Mac
;; Returns the true (effective) name of a supplied block reference

(defun LM:blockname ( obj )
(if (vlax-property-available-p obj 'effectivename)
(defun LM:blockname ( obj ) (vla-get-effectivename obj))
(defun LM:blockname ( obj ) (vla-get-name obj))
)
(LM:blockname obj)
)

;; Start Undo - Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)

;; End Undo - Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)

;; Active Document - Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)

;;----------------------------------------------------------------------;;

(vl-load-com) (princ)
;(c:cxpr)

Advertisements