(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
)
