Marko,
I was having some errors with your code, hope you don't mind, I made some changes.
Think I made the same thing, but whit out using script, and with vla functions.
igal,
Sorry I didn't answer immediately.
Please before using this function, please backup all external references and current drawing, because this lisp is modifying external references.
It moves objects in xref form point 0,0,0 to point which one is same as xref insertpoint in active drawing. On that way insertpoint in xref is 0,0,0 in active drawing, and objects of xref are on the same location as in active drawing.
Because xref drawings are changed, please test this routine on example drawing, so that we be sure that this is what you wanted.
Only thing which I'm not sure about it, is because I made selection set of all objects in xref (vla-select newss acselectionsetall).
In that selection set are some vla-objects which are not entitys in drawing, I applied vla-move on all of them.
I don' know if this is wrong, hope that some one more experience will answer.
Anyway, I didn't find any problems while I was using this routine, on my example drawing.
;; Retains Xref Reference Position
(defun c:cxpr (/ ss entlst newss ssets v-ent pt1 pat docs)
(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 pt1 (cdr (assoc 10 (entget ent))))
(LM:changeblockbasepoint t ent)
(setq v-ent (vlax-ename->vla-object ent))
(setq pat (vla-get-path v-ent))
(setq docs (vla-get-Documents (vlax-get-Acad-Object)))
(setq x-open (vla-Open docs pat :vlax-false))
(setq ssets (vla-get-selectionsets x-open))
(setq newss (vla-add ssets "SS1"))
(vla-select newss acselectionsetall)
(vlax-for item newss (vla-move item (vlax-3d-point '(0 0 0)) (vlax-3d-point pt1)))
(vla-delete (vla-item ssets "SS1"))
(vla-close x-open)
) ;end progn
)
)
(princ)
)
;;----------------------------------------------------------------------;;
(defun LM:changeblockbasepoint
(flg ent / *error* bln cmd lck mat nbp 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)) (setq nbp '(0.0 0.0 0.0)))
(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)
Hope this is what you are looking for.
cheers,
dicra
![Autodesk Design & Make Report](https://forums.autodesk.com/t5/image/serverpage/image-id/1350519iCB55845EBFC43016/image-size/large?v=v2&px=999" "Autodesk Design & Make Report")
