# TheSwamp

## Code Red => AutoLISP (Vanilla / Visual) => Topic started by: ronjonp on November 04, 2004, 11:40:22 AM

Title: Centroid Lisp
Post by: ronjonp on November 04, 2004, 11:40:22 AM
Do any of you have a lisp that will give you the centroid of a closed polyline?

Thanks,

Ron
Title: Centroid Lisp
Post by: hendie on November 04, 2004, 11:46:41 AM
the CENT routine over at www.resourcecad.com can place a point at the centroid if it's a region. a closed polyline doesn't have a centroid property as such
is that what you're after or are you looking for a lisp which will return the centroid as data coordinates ?
Title: Centroid Lisp
Post by: CAB on November 04, 2004, 11:51:08 AM
Code: [Select]
`;; ******************************************************************************;; Determine centroid of a polygon;;;; Algorithm:;; 1. Form trapezoids by dropping lines from each segment to a basey axis.;; 2. Calculate the area and CG of the triangle and rectangle in each trapezoid ;; 3. Sums up weighted moments against given axes in X and Y direction;;    (may use x and y axes if number is small);; 4. Derived CG by dividing weighted sum by total area.;; ******************************************************************************(defun GE_centroid(vlist / segno n ttl_area basex basey p1 p2 x1 x2 y1 y2 t_x t_y t_area t_xm t_ym r_x r_y r_area r_xm r_ym Mx My)(setq vlist (append vlist (list (car vlist))) segno (1- (length vlist))    ; no of segments n 0 Ttl_Area 0.0 ; total area Mx 0.0 ; Sum of moment to basex line My 0.0 ; Sum of moment to basey line basex (car  (nth 0 vlist)) ; arbitrary axes (will reduce error for large numbers) basey (cadr (nth 0 vlist)))(repeat segno (setq p1 (nth n vlist) ; process current segment p2 (nth (1+ n) vlist) x1 (car p1) y1 (cadr p1) x2 (car p2) y2 (cadr p2) ; For the triangle t_x (- (* (+ x2 x2 x1) 0.333333) basex) ; cg of trianlge t_y (- (* (+ y1 y1 y2) 0.333333) basey) t_area (* (- y2 y1) (- x2 x1) 0.5) ; area of triangle t_xm (* t_area t_x) ; moment to Basex t_ym (* t_area t_y) ; moment to basey ; For the rectangle r_x (- (/ (+ x1 x2) 2) basex) ; CG of rectangle r_y (- (/ (+ basey y1) 2) basey) r_area (* (- x2 x1) (- y1 basey)) ; area of rectangle r_xm (* r_area r_x) ; moment to basex r_ym (* r_area r_y) ; moment to basey Ttl_Area (+ Ttl_Area t_area r_area) Mx (+ Mx  t_xm r_xm) ; adds up moments to basex My (+ My  t_ym r_ym) ; adds up moments to basey n (1+ n) ))(list (+ (/ Mx Ttl_Area) basex) (+ (/ My Ttl_Area) basey)))`
Title: Centroid Lisp
Post by: ronjonp on November 04, 2004, 12:04:01 PM
thanks guys.  :D
Title: Re: Centroid Lisp
Post by: Aldo on May 10, 2019, 01:50:54 PM
I found it on the web, I hope it's of your use

(defun c:pc ( / acdoc acspc acsel pl bl ) (vl-load-com)
acspc (vlax-get-property acdoc (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace))
)
(if (ssget '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1)))
(progn
(vlax-for obj (setq acsel (vla-get-ActiveSelectionSet acdoc))
(trans
(progn
(setq pl nil bl nil)
(foreach a (reverse (entget (vlax-vla-object->ename obj)))
(cond ((= (car a) 10) (setq pl (cons (cdr a) pl)))
((= (car a) 42) (setq bl (cons (cdr a) bl)))
); _  cond
); _  foreach
;;;(eea-centroid-solid-lw pl bl)
[color="red"]  (reverse(cons (vla-get-elevation obj)(reverse (eea-centroid-solid-lw pl bl))));;;VVA MOD 2015-03-29[/color]
)
1 0)
)
)
(vla-delete acsel)
)
)
(princ)
)

(defun eea-centroid-solid-lw (pl bl / A1)
;|
***********************************************************************
by ElpanovEvgeniy
Library function,
Centroids (center of masses) of region, inside [polilinii], which has arched segments.
pl - list of the apexes of [polilinii] (code 10)
bl - list of tangents fourth of angle of the arched segments of [polilinii] (code 42)
Date of the creation      2000 - 2005
Last editorial staff 08.06.2009
URL http://elpanov.com/index.php?id=46

*********************************************************************
Library of function.
Centroid (the of center of of weights) of region, inside of a of polyline, having of arc of segments
pl - list of point
bl - list of bulge
Date of of creation   2000 - 2005 years.
Last of edit 08.06.2009
**********************************************************************
(setq e  (car (entsel "\n Select LWPOLYLINE "))
pl nil
bl nil
) ;_  setq
(foreach a (reverse (entget e))
(cond ((= (car a) 10) (setq pl (cons (cdr a) pl)))
((= (car a) 42) (setq bl (cons (cdr a) bl)))
) ;_  cond
) ;_  foreach
(eea-centroid-solid-lw pl bl)
*****************************************************************
(defun c:test (/ e bl pl)
(setq e (car (entsel "\n Select LWPOLYLINE ")))
(foreach a (reverse (entget e))
(cond ((= (car a) 10) (setq pl (cons (cdr a) pl)))
((= (car a) 42) (setq bl (cons (cdr a) bl)))
) ;_  cond
) ;_  foreach
(entmakex (list '(0 . "point")
'(62 . 1)
(cons 10 (eea-centroid-solid-lw pl bl))
(assoc 210 (entget e))
) ;_  list
) ;_  entmakex
) ;_  defun
*******************************************************************
|;
(setq a1 0)
(mapcar
(function /)
(apply
(function mapcar)
(cons
(function +)
(mapcar
(function
(lambda (p1 p2 b / A BB C I S)
(setq i  (/ (- (* (car p1) (cadr p2)) (* (car p2) (cadr p1))) 2)
a1 (+ i a1)
i  (/ i 3)
) ;_  setq
(if (zerop b)
(mapcar (function (lambda (a b) (* (+ a b) i))) p1 p2)
(progn
(setq c  (distance p1 p2)
bb (* b b)
a  (/ (* c c (- (* (atan b) (1+ bb) (1+ bb)) (* b (- 1 bb)))) (* 8 bb))
a1 (+ a a1)
s  (/ (- (* b c c) (* 3 a (- 1 bb))) (* 12 a b))
) ;_  setq
(mapcar (function (lambda (a b c d) (+ (* (+ a b) i) (* d (+ (/ (+ a b) 2) c)))))
p1
p2
(list (* (- (cadr p2) (cadr p1)) s) (* (- (car p2) (car p1)) -1 s))
(list a a)
) ;_  mapcar
) ;_  progn
) ;_  if
) ;_  lambda
) ;_  function
(cons (last pl) pl)
pl
(cons (last bl) bl)
) ;_  mapcar
) ;_  cons
) ;_  apply
(list a1 a1)
) ;_  mapcar
) ;_  defun
Title: Re: Centroid Lisp
Post by: gile on May 10, 2019, 02:53:11 PM
Hi,

See this topic (http://www.theswamp.org/index.php?topic=18725).
Title: Re: Centroid Lisp
Post by: ribarm on May 11, 2019, 10:30:38 AM
Just for your info, centroid point can be from mass - 3DSOLID centroid, from area - REGION centroid and from curve - open/closed which is not documented by AutoCAD... I just happen to have the one that determines ARC centroid of arc as curve and area of chord and area of circle segment... For LWPOLYLINE with arcs it would be easy to find, just obtain from each arc like described in the code and from linear segments it's at middle of each line... Then you sum all X coords multiplied with each segments lengths and divide by total length of LWPOLYLINE for X centroid coord and the same for Y... The problem are splines as curves - not areas as if they are closed they could be converted to REGIONS and get area centroids - the problem is curve centroid - that is even now for me unknown... And beside all this even CAD can make small miscalculations with area and mass centroids : sometimes - (vla-get-centroid) is different than "gcen" OSNAP and MASSPROP centroid claculation... So here is for ARC if you are still interested :

Code - Auto/Visual Lisp: [Select]
1. (defun c:arccentroid ( / arc c r a d1 d2 d3 p cen1 cen2 cen3 )
2.
3.
4.   (while (or (not (setq arc (car (entsel "\nPick an arc...")))) (if arc (/= (cdr (assoc 0 (entget arc))) "ARC")))
5.     (prompt "\nMissed or picked wronf entity type...")
6.   )
7.   (setq c (cdr (assoc 10 (entget arc))))
8.   (setq r (cdr (assoc 40 (entget arc))))
9.   (setq a (rem (+ pi pi (- (cdr (assoc 51 (entget arc))) (cdr (assoc 50 (entget arc))))) (+ pi pi)))
10.   (setq d1 (/ (* 4.0 r (expt (sin (/ a 2.0)) 3)) (* 3.0 (- a (sin a)))))
11.   (setq d2 (/ (* r (sin (/ a 2.0))) (/ a 2.0)))
12.   (setq d3 (/ (* 2.0 r (sin (/ a 2.0))) (* 3.0 (/ a 2.0))))
13.   (setq cen1 (mapcar '+ (trans c arc 0) (mapcar '(lambda ( x ) (* (/ x (distance (trans c arc 0) p)) d1)) (mapcar '- p (trans c arc 0)))))
14.   (setq cen2 (mapcar '+ (trans c arc 0) (mapcar '(lambda ( x ) (* (/ x (distance (trans c arc 0) p)) d2)) (mapcar '- p (trans c arc 0)))))
15.   (setq cen3 (mapcar '+ (trans c arc 0) (mapcar '(lambda ( x ) (* (/ x (distance (trans c arc 0) p)) d3)) (mapcar '- p (trans c arc 0)))))
16.   (entmake (list '(0 . "POINT") (cons 10 cen1) '(62 . 1)))
17.   (entmake (list '(0 . "LINE") (cons 10 (vlax-curve-getstartpoint arc)) (cons 11 (vlax-curve-getendpoint arc)) '(62 . 1)))
18.   (entmake (list '(0 . "POINT") (cons 10 cen2) '(62 . 2)))
19.   (entmake (list '(0 . "POINT") (cons 10 cen3) '(62 . 3)))
20.   (entmake (list '(0 . "LINE") (cons 10 (vlax-curve-getstartpoint arc)) (cons 11 (trans c arc 0)) '(62 . 3)))
21.   (entmake (list '(0 . "LINE") (cons 10 (vlax-curve-getendpoint arc)) (cons 11 (trans c arc 0)) '(62 . 3)))
22.   (princ)
23. )
24.

HTH., M.R.
Title: Re: Centroid Lisp
Post by: notredave on May 15, 2019, 08:17:35 AM
Aldo or anybody,

Good morning. Can someone tell me a way to make Aldo's lisp routine tell me c:pc when loaded to execute. I named this lisp "centroid.lsp" to know what it is but when I load it, it tells me "EEA-CENTROID-SOLID-LW"

Thank you very much in advance,
David
Title: Re: Centroid Lisp
Post by: ronjonp on May 15, 2019, 08:58:12 AM
Quick glance and you need to remove [color="red"] from the code.
Title: Re: Centroid Lisp
Post by: MSTG007 on May 15, 2019, 09:15:39 AM
I gonna ask. What are wanting to do? Curious. I know....
Title: Re: Centroid Lisp
Post by: notredave on May 15, 2019, 09:32:16 AM
MSTG007,

I would like to know after I load centroid.lsp, what command to execute? Currently it comes back with EEA-CENTROID-SOLID-LW after loaded but looking at lisp, it says (defun c:pc...
I want it to return with pc to start lisp.

Thank you,
David
Title: Re: Centroid Lisp
Post by: Lee Mac on May 15, 2019, 12:29:38 PM
MSTG007,

I would like to know after I load centroid.lsp, what command to execute? Currently it comes back with EEA-CENTROID-SOLID-LW after loaded but looking at lisp, it says (defun c:pc...
I want it to return with pc to start lisp.

Thank you,
David

'pc' is the command which may be used to invoke the program at the command-line, as this function has been defined with a 'c:' prefix; EEA-CENTROID-SOLID-LW is returned at the command-line after loading because this is the value returned by the last expression evaluated by the load function when the AutoLISP file is loaded, i.e. the value returned by the defun expression - if you don't want to see this returned at the command-line on loading, simply add (princ) on a new line at the very end of the file.
Title: Re: Centroid Lisp
Post by: notredave on May 15, 2019, 01:26:14 PM
Lee,

Thank you very much for your response. I put (princ) at the end and that worked. What I'm asking is that after I load centroid.lsp that it returns with c:PC to let me know what invokes it.

Thank you,
David
Title: Re: Centroid Lisp
Post by: Lee Mac on May 15, 2019, 01:44:17 PM
Thank you very much for your response. I put (princ) at the end and that worked. What I'm asking is that after I load centroid.lsp that it returns with c:PC to let me know what invokes it.

No problem - add something like the following to the end of the file:
Code: [Select]
`(princ "\nType 'PC' to invoke the program.")(princ)`
Alternatively, remove the final (princ) and reorder the two defun expressions.

Title: Re: Centroid Lisp
Post by: notredave on May 15, 2019, 01:55:23 PM
Thank you very much Lee!!! That did the trick. I appreciate you.

David
Title: Re: Centroid Lisp
Post by: BIGAL on May 16, 2019, 11:36:42 PM
If you want to hit them in the face change the princ in Lee's code to Alert. You can also add extra lines if you want also.

Code: [Select]
`(princ "\nType 'PC' to invoke the program.")(alert "Type 'PC' to invoke the program.\n\nDont forget abot the other options\nA or B\n Folowed by C")`
Title: Re: Centroid Lisp
Post by: myloveflyer on May 27, 2019, 09:09:07 PM
Code: [Select]
`(alert "\n The program command is TEST, the specific usage is as follows:         \n unit and precision are determined by ACAD, you can control it yourself, select closed line segment objects, or region objects,\n When prompted for data output mode, press P or W key, P stands for screen output, and W creates data on C: drive.\nPlease respect the original, not for commercial purposes!! Highflybird 2007.1.23 KunMing")(defun mas (obj / Area Area1 Area2 Perimeter Centroid Centroid1 Centroid2 MomentOfInertiaMomentOfInertia1 PrincipalDirections PrincipalMoments minpt maxpt Sx SyProductOfInertia ProductOfInertia1 RadiiOfGyration Wx1 Wx2 Wy1 Wy2 obj1Obj2 recPt1 recPt2 reg1 reg2 CenX CenY)  (if (= "AcDbRegion" (vla-get-objectname obj)) ; if it is a section, then calculate    (progn      (setq Area (vla-get-area obj); area            Perimeter (vla-get-Perimeter obj) ; perimeter            Centroid (V2L (vla-get-Centroid obj)); centroidMomentOfInertia (V2L (vla-get-MomentOfInertia obj)); moment of inertia            PrincipalDirections (V2L (vla-get-PrincipalDirections obj)); direction of the principal momentPrincipalMoments (V2L (vla-get-PrincipalMoments obj)); the principal moment and the X-Y direction of the centroidProductOfInertia (vla-get-ProductOfInertia obj) ; inertia product      ); setq      (vla-move obj (vlax-3d-point Centroid) (vlax-3d-point '(0 0))); moving the centroid to the origin      (setq MomentOfInertia1 (V2L (vla-get-MomentOfInertia obj)); centroid moment of inertiaProductOfInertia1 (vla-get-ProductOfInertia obj) ; the inertia product of the centroidRadiiOfGyration (V2L (vla-get-RadiiOfGyration obj)); radius of gyration      ); setq      (vla-getboundingbox obj 'minpt 'maxpt) ; bounding box      (setq minpt (vlax-safearray->list minpt) ; bottom left corner            Maxpt (vlax-safearray->list maxpt) ; top right corner            Wx1 (/ (car MomentOfInertia1) (cadr minpt)); resistance momentWx2 (/ (car MomentOfInertia1) (cadr maxpt))Wy1 (/ (cadr MomentOfInertia1) (car minpt))Wy2 (/ (cadr MomentOfInertia1) (car maxpt))      ); setq      (vla-move obj (vlax-3d-point '(0 0)) (vlax-3d-point Centroid)) ; moved back to its original location      (setq obj1 (vla-copy obj) ; copy the object to calculate the X area moment            Obj2 (vla-copy obj) ; copy the object to calculate the Y area moment            CenX (car Centroid)CenY (cadr Centroid)            recPt1 (list (+ CenX (car minpt) -1) CenY ; create a point table for two rectangular regions(+ CenX (car maxpt) +1) CenY(+ CenX (car maxpt) +1) (+ CenY (cadr minpt) -1)(+ CenX (car minpt) -1) (+ CenY (cadr minpt) -1))recPt2 (list (+ CenX (car minpt) -1) (+ CenY (cadr minpt) -1)(+ CenX (car minpt) -1) (+ CenY (cadr maxpt) +1)CenX (+ CenY (cadr maxpt) +1)CenX (+ CenY (cadr minpt) -1))            Reg1 (draw-rectange recPt1) ; create area 1Reg2 (draw-rectange recPt2) ; create area 2      )      (vla-boolean obj1 acSubtraction reg1) ; find the difference between obj1 and area 1      (vla-boolean obj2 acSubtraction reg2) ; find the difference between obj2 and area 2      (setq Area1 (vla-get-area obj1) ; find the area of ​​obj1Area2 (vla-get-area obj2) ; seek area of ​​obj2Centroid1 (V2L (vla-get-Centroid obj1)); seeking the centroid of obj1Centroid2 (V2L (vla-get-Centroid obj2)); seeking the centroid of obj2            Sx (* Area1 (- (cadr Centroid1) (cadr Centroid))); around the X-axis area moment (static moment)Sy (* Area2 (- (car Centroid2) (car Centroid))); area around the Y axis (static moment)      )      (vla-delete obj1) ; delete area 1      (vla-delete obj2) ; delete area 2      (list (cons "area" Area); returns various parameter values(cons "perimeter" Perimeter)(cons "centroid" Centroid)(cons "X Principal Moment" (car PrincipalMoments)(cons "X-axis moment of inertia" (car MomentOfInertia1))(cons "Y axis main moment of inertia" (cadr PrincipalMoments)(cons "Y-axis moment of inertia" (cadr MomentOfInertia1))(cons "XY Inertia Product" ProductOfInertia1)(cons "bending resistance on the X axis" Wx2)(cons "X-axis bending resistance" (Wx1)(cons "Y axis left bending distance" Wy1)(cons "Y axis right bending resistance" Wy2)(cons "X-axis area moment" Sx )(cons "Y axis area moment" Sy )(cons "swirl radius ix" (car RadiiOfGyration))(cons "swirl radius iy" (cadr RadiiOfGyration))(cons "car PrincipalDirections" (caddr PrincipalDirections)))(cons "cadr PrincipalDirections" (cadddr PrincipalDirections)))(cons "distance from the left" (abs (car minpt)))(cons "distance from the right" (abs (car maxpt)))(cons "distance from the top" (abs (cadr maxpt)))(cons "distance from the bottom" (abs (cadr minpt)))      )    )  ));;;Draw a rectangular area with ActiveX(defun draw-rectange (recpts / pts rec reg)  (setq pts (vlax-make-safearray vlax-vbdouble '(0. 7)))  (vlax-safearray-fill pts recpts)  (setq rec (vla-addlightweightPolyline *MSP pts)); create a rectangle  (vla-put-closed rec 1) ; closed rectangle  (setq reg (vla-addregion *MSP (O2L rec)));  (vla-delete rec) - delete the light polyline of the rectangle  (car (V2L reg));;;ActiveX variables are converted to lisp list(defun V2L (x)  (vlax-safearray->list (vlax-variant-value x)));;; convert the object of the selection set into a safe array(defun S2A (ss / i l objs curves)  (setq i -1 l (sslength ss) objs nil)  (repeat l    (setq objs (cons (vlax-ename->vla-object (ssname ss (setq i (1+ i)))) objs))  )  (setq curves (vlax-make-safearray vlax-vbobject (eval '(cons 0 (1- l)))))  (vlax-safearray-fill curves objs));;; convert the object of the selection set to a Lisp table(defun S2L (ss / i l objs)  (setq i -1 l (sslength ss) objs nil)  (repeat l    (setq objs (cons (vlax-ename->vla-object (ssname ss (setq i (1+ i)))) objs))  ));;; object composition lisp list(defun O2L (obj / curves)  (setq curves (vlax-make-safearray vlax-vbobject '(0 . 0)))  (vlax-safearray-fill curves (list obj)));;; print the section table and count(defun GetNum (regobjs Num / Number reglst)  (setq Number Num) ; count to zero  (foreach obj regobjs    (setq reglst (mas obj)) ; evaluate it separately    (princ obj) ; print the region name    (princ "\n below is a list of parameters for this object: ")    (foreach n reglst (princ "\n") (princ n)) ; print region parameter table    (setq Number (1+ Number)); count accumulate  ));;;table converted to a string(defun L2S (lst / s)  (setq s(apply'strcat(mapcar '(lambda(x)(strcat (rtos x) " ")) lst))  )  (setq s (substr s 1 (1- (strlen s))))  (strcat "(" s ")"));;;write data function(defun WrData (regobjs Num / Number reglst string str1 str2 str)  (setq Number Num) ; count to zero  (foreach obj regobjs    (setq reglst (mas obj)) ; evaluate it separately    (setq Number (1+ Number)); count accumulate    (write-line "***********************************" file)    (setq string (strcat "section" (itoa Number)" parameter list: "))    (write-line string file) ; write the region name    (foreach n reglst      (setq str1 (car n)) ; parameter name      (if (listp (setq str2 (cdr n))); parameter value(setq str2 (L2S str2))(setq str2 (rtos str2))      )      (setq str (strcat str1 ": " str2))      (write-line str file) ; write region parameter table    )  )  Number);;;The following test procedure(defun C:test (/ *APP *DOC *MSP i j ss ss1 err objlst REGs W&P OLDCMD OldUcs file)  (vl-load-com)  (setq *APP (vlax-get-acad-object)*DOC (vla-get-activeDocument *APP)*MSP (vla-get-Modelspace *DOC)  )  (princ)  (if (setq ss (ssget)) ; establish a selection set    (progn      (initget 1 "W P") ; choose to write to file or screen print      (setq W&P (getkword "\n determine the output data mode: \n write file [W] or screen print [P])?"))      (princ "\n")      (setq OLDCMD (getvar "CMDECHO"))      (setvar "CMDECHO" 0)      ;;(command ".UCS" "W")      (uu 1)      (setq objlst (S2A ss)) ; selection set list      (if (setq ss1 (ssget "P" '((0 . "REGION"))))); select the existing region in the set(setq i (if (= W&P "P") ; calculate and find the number of regions(GetNum (S2L ss1) 0)(progn(setq file (open "C:\\section geometry parameter.TXT""W")); open file                    (Wrdata (S2L ss1) 0))))(setq i 0)      )      (defun addreg ()(setq REGs (vla-addregion *MSP objlst))      )      (setq err (vl-catch-all-apply 'addreg)) ; create area and error detection      (if (vl-catch-all-error-p err) ; if no new region is created        (setq j 0) ; then the count is 0(setq REGs (V2L REGs) ; otherwise converted to region collection              i (if (= W&P "P") ; calculate and find the number of regions(GetNum REGs i)(progn(setq file (open "C:\\section geometry parameter.TXT""A")); open file(Wrdata REGs i)))j (mapcar 'vla-delete REGs) ; delete the newly created section)      )      (close file) ; close the file      (if (/= 0 i)(progn          (princ "\n\n is already listed")          (princ i)          (princ "section geometry table."))(alert "The valid section is not selected!")      )      ;;(command ".UCS" "P")      (uu 0)      (setvar "CMDECHO" OLDCMD)    )    (alert "You have no objects selected!")  )  (gc)  (princ))(defun uu (T&F / WCSOrg WCSXDr WCSYDr WCSObj OldOrg OldXDr OldYDr *UTI *UCS)  (setq *UTI (vla-get-Utility *DOC) ; Get the Utility set*UCS (vla-get-UserCoordinateSystems *DOC); get UCS set  )  (setq WCSOrg (vlax-3d-point '(0 0 0))); WCS origin  (setq WCSXDr (vlax-3d-point '(1 0 0)))  (setq WCSYDr (vlax-3d-point '(0 1 0)))  (setq WCSObj (vla-add *UCS WCSOrg WCSXDr WCSYDr "WCS"))  (if (= T&F 1)    (progn      (if (= (getvar "UCSNAME") "") ; the current UCS name, if not named, then        (progn          (setq OldOrg (vla-GetVariable *DOC "UCSORG") ; take the current UCS origin  OldXDr (vla-getVariable *DOC "UCSXDIR") ; take the current X directionOldYDr (vla-getVariable *DOC "UCSYDIR") ; take the current Y directionOldUcs (vla-add *UCS WCSOrg OldXDr OldYDr "OLD"); establish the current UCS, but the origin is at '(0,0,0)          )          (vla-put-origin OldUcs OldOrg) ; change the origin to the current UCS origin        )        (setq OldUcs (vla-get-ActiveUcs *DOC)) ; if named, get UCS object      )      (vla-put-ActiveUcs *DOC WCSobj)    )    (vla-put-ActiveUcs *DOC OldUcs)  )  OldUcs)`