Change x-ref files base point to WCS (0,0,0) all at once

[igal1971]

Hi everyone!

Does anyone know where i can get a lisp routine on how to change xref files base point to WCS (0,0,0) all at once? Your help is highly appreciated.

I don't need to move it to 0,0 only to change base point (xref's must to remain in old places)

[igal1971]

Marco i'm realy sorry about my stupidity, but i still have a problem with this code. I use following code

;; Retains Xref Reference Position
(defun c:cxpr ( / ss entlst pp p r ppentlst f )
    (command "_.UCS" "_W")
    (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 p (cdr (assoc 10 (entget ent))))
                (setq r (cdr (assoc 50 (entget ent))))
                (LM:changeblockbasepoint t ent)
                (setq pp (polar '(0.0 0.0 0.0) (- (angle '(0.0 0.0 0.0) p) r) (distance '(0.0 0.0 0.0) p)))
                (setq ppentlst (cons (cons pp ent) ppentlst))
            )
        )
    )
    (setq f (open "c:/scr.scr" "w"))
    (write-line "_.QSAVE" f)
    (foreach ppent ppentlst
        (write-line "_.OPEN" f)
        (if (vl-file-directory-p (vla-get-path (vlax-ename->vla-object (cdr ppent))))
            (write-line (strcat "\"" (vla-get-path (vlax-ename->vla-object (cdr ppent))) "\"") f)
            (write-line (strcat "\"" (findfile (strcat (getvar 'dwgprefix) (vla-get-path (vlax-ename->vla-object (cdr ppent))))) "\"") 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 ppent) 2 50) "," (rtos (cadar ppent) 2 50) "," (rtos (caddar ppent) 2 50)) f)
        (write-line "_.LAYERP" f)
        (write-line "_.QSAVE" f)
    )
    (write-line "_.CLOSEALL" f)
    (close f)
    (alert "After reopening master DWG, type (vl-file-delete \"c:/scr.scr\")")
    (command "_.SCRIPT" "c:/scr.scr")
    (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)

 VlIDE don't find any problem (i mean a sintax one) but during execution of this routine we have mentioned error

Can you attach a compile version (fas) to your post because i think the problem is somewhere in code page

[marko_ribar]

I don't understand, you want me to attach the same code... I am attaching my lsp file... Just rename (remove .txt) extension...

[marko_ribar]

Complied files...

[igal1971]

thank you Marco

[igal1971 · Accepted solution]

I changed it a little and now it's work properly for me:

http://lispbox.wordpress.com/2014/12/14/move-xref-insertion-point-to-000-but-retains-xref-reference-...

[marko_ribar]

---

@igal1971 wrote:

Hi Marco!

You did a very good work (I'm talking about lisp "Change x-ref files base point to WCS (0,0,0) all at once") I started to use it very often and suddenly found a little problem. I mean when you have

scaled xref programm working not properly (xref moved - lost prevous position). Can you fix it?

Thank you for the help

Igal

Hi Igal, you spelled wrongly my name its Marko Ribar, not Marco_ribar how you publiced... Here is my final mod for this topic, should work for 3D positioned Xrefs that are rotated 3D in space and that have varius scale factors...

;; Retains Xref Reference Position
(defun c:cxpr ( / ss entlst p pentlst scfx scfy scfz bp f )
    (command "_.UCS" "_W")
    (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)
        (if (vl-file-directory-p (vla-get-path (vlax-ename->vla-object (cdr pent))))
            (write-line (strcat "\"" (vla-get-path (vlax-ename->vla-object (cdr pent))) "\"") f)
            (write-line (strcat "\"" (findfile (strcat (getvar 'dwgprefix) (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)
    (alert "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)

 HTH, Regards, M.R.

[marko_ribar]

Hi Marco!

You did a very good work (I'm talking about lisp "Change x-ref files base point to WCS (0,0,0) all at once") I started to use it very often and suddenly found a little problem. I mean when you have

scaled xref programm working not properly (xref moved - lost prevous position). Can you fix it?

Thank you for the help

Igal

[igal1971]

I'm sorry about wrong spelling it was Unintentionally

[marko_ribar]

Thanks for updating publication... Though, one small revision is also necessity :

In 4th line :

(setq ss (ssget '((0 . "INSERT"))))

should be added "_:L" mode, as later I use (vla-move) on Xref, so if its not big problem to fix it, I would do it...

(setq ss (ssget "_:L" '((0 . "INSERT"))))

Thanks, Igal1971

AKA ? (your real name)

Regards, M.R.

[igal1971]

Hi Marko!

In a weekend I did some experements with your small eddition ( I mean from the previous post) and unfortunaly did not find any difference between previous and curent programm functionality. For me program working 100% without this addition. Can you send me some examples when programm will start to work problematicaly without this eddition?

[marko_ribar]

When you have Xrefs that are on locked layers, with (setq ss (ssget '((0 . "INSERT")))), AutoCAD will alow selecting all of them - and ones that are on locked layers... This means that when this kind of Xrefs are processing, (vla-move) function that is later called will fail, because AutoCAD don't allow moving locked entities and therefore routine may not work correctly - it will break on some point while routine iterates through sel. set  of Xrefs... With (setq ss (ssget "_:L" '((0 . "INSERT")))), you explicitely tell to AutoCAD that skip those Xrefs that are on locked layers while selecting entities... This ensures that only valid Xrefs will be processed and therefore routine won't break no matter you have some Xrefs on locked layers or not... Simply those that are on locked layers won't be selected - that is what "_:L" stands for - prevent selection of entities that are on locked layers... That's it, this small thing, but evidentely very important if wanting to make routine work as expected...

[igal1971]

Your arguments convinced me!

Publication updated see it:

http://lispbox.wordpress.com/2014/12/14/move-xref-insertion-point-to-000-but-retains-xref-reference-...

[igal1971]

Important remark: If you set xloadctl variable not equal to 0
programm working not correctly