Author Topic: Centroid Lisp  (Read 2548 times)

0 Members and 1 Guest are viewing this topic.

ronjonp

  • Needs a day job
  • Posts: 6938
Centroid Lisp
« 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

Windows 10 x64 - AutoCAD /C3D 2020

Custom Build PC

hendie

  • Guest
Centroid Lisp
« Reply #1 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 ?

CAB

  • Global Moderator
  • Seagull
  • Posts: 10339
Centroid Lisp
« Reply #2 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))
)
I've reached the age where the happy hour is a nap. ()
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

ronjonp

  • Needs a day job
  • Posts: 6938
Centroid Lisp
« Reply #3 on: November 04, 2004, 12:04:01 PM »
thanks guys.  :D

Windows 10 x64 - AutoCAD /C3D 2020

Custom Build PC

Aldo

  • Mosquito
  • Posts: 18
Re: Centroid Lisp
« Reply #4 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)
 (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
       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))
       (vlax-invoke acspc 'addpoint
         (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

gile

  • Water Moccasin
  • Posts: 2219
  • Marseille, France
Re: Centroid Lisp
« Reply #5 on: May 10, 2019, 02:53:11 PM »
Hi,

See this topic.
Speaking English as a French Frog

ribarm

  • Water Moccasin
  • Posts: 2091
  • Marko Ribar, architect
Re: Centroid Lisp
« Reply #6 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.
« Last Edit: May 11, 2019, 11:07:15 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

notredave

  • Newt
  • Posts: 67
Re: Centroid Lisp
« Reply #7 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

ronjonp

  • Needs a day job
  • Posts: 6938
Re: Centroid Lisp
« Reply #8 on: May 15, 2019, 08:58:12 AM »
Quick glance and you need to remove [color="red"] from the code.

Windows 10 x64 - AutoCAD /C3D 2020

Custom Build PC

MSTG007

  • Water Moccasin
  • Posts: 2376
  • I can't remeber what I already asked! I need help!
Re: Centroid Lisp
« Reply #9 on: May 15, 2019, 09:15:39 AM »
I gonna ask. What are wanting to do? Curious. I know....
Autodesk Infrastructure Design Suite 2019

notredave

  • Newt
  • Posts: 67
Re: Centroid Lisp
« Reply #10 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

Lee Mac

  • Seagull
  • Posts: 12225
  • London, England
Re: Centroid Lisp
« Reply #11 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.

notredave

  • Newt
  • Posts: 67
Re: Centroid Lisp
« Reply #12 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

Lee Mac

  • Seagull
  • Posts: 12225
  • London, England
Re: Centroid Lisp
« Reply #13 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.


notredave

  • Newt
  • Posts: 67
Re: Centroid Lisp
« Reply #14 on: May 15, 2019, 01:55:23 PM »
Thank you very much Lee!!! That did the trick. I appreciate you.

David

BIGAL

  • Bull Frog
  • Posts: 270
  • 30 + years of using Autocad
Re: Centroid Lisp
« Reply #15 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")
A man who never made a mistake never made anything

myloveflyer

  • Newt
  • Posts: 115
Re: Centroid Lisp
« Reply #16 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 MomentOfInertia
MomentOfInertia1 PrincipalDirections PrincipalMoments minpt maxpt Sx Sy
ProductOfInertia ProductOfInertia1 RadiiOfGyration Wx1 Wx2 Wy1 Wy2 obj1
Obj2 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)); centroid
MomentOfInertia (V2L (vla-get-MomentOfInertia obj)); moment of inertia
            PrincipalDirections (V2L (vla-get-PrincipalDirections obj)); direction of the principal moment
PrincipalMoments (V2L (vla-get-PrincipalMoments obj)); the principal moment and the X-Y direction of the centroid
ProductOfInertia (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 inertia
ProductOfInertia1 (vla-get-ProductOfInertia obj) ; the inertia product of the centroid
RadiiOfGyration (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 moment
Wx2 (/ (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 1
Reg2 (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 ​​obj1
Area2 (vla-get-area obj2) ; seek area of ​​obj2
Centroid1 (V2L (vla-get-Centroid obj1)); seeking the centroid of obj1
Centroid2 (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 direction
OldYDr (vla-getVariable *DOC "UCSYDIR") ; take the current Y direction
OldUcs (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
)
Never give up !