;| Centroid.lsp  - returns in current UCS coordinates the centroid of
   a selected object that can be in any UCS:
     - region
     - 3Dsolid
     - circle
     - ellipse
     - closed polyline (heavy)
     - closed LWpolyline
     - closed planar spline
     - closed planar 3Dpolyline

If used transparently, returns a point list to the calling command:
    Command: line
    Specify first point: 'CENTROID
    Select object to find centroid:     <<select object, line starts>>
    Specify next point or [Undo]:       <<continue line>>

If not used transparently, creates a POINT object on the current layer.

In either case, coordinates of the most recently selected object are
saved in symbol CENTRO for later use.

Does not work with hatches, objects that cross themselves, or other
2D objects that cannot be turned into REGIONs.

If the current layer is locked or off, it is unlocked and turned on.

by Bill Gilliss
bill <at> realerthanreal <dot> com
Comments and suggestions always welcome.

Many thanks to 
  Kent Cooper for (PolylineSelfCrossing)
  gile for (Normal3Points)

No warranty, either expressed or implied, is made as to the fitness of
this information for any particular purpose.   All materials are to be
considered 'as-is' and use thereof should be considered as at your own
risk.

ver 1.0  Apr 14 2010 - initial public release
Check for updates at www.realerthanreal.com/autolisp

Keywords: AutoCAD AutoLISP centroid OSNAP transparent
======================================================================
|;

(defun c:centroid 
  (/ *delobj *osmode e en entype ed obj prevEn newEn myerror
    polylineSelfCrossing Normal3Points CrossProduct Normalize ScaleVector
    setUCStoObject ucsSave makeRegion acadObj acadDoc *Modelspace 
    newUCS origUCS objUCS lay layStatus )

  (vl-load-com)

;;=======subroutines========
  ;;  Function name: PSC = Polyline Self-Crossing
  ;;  To determine whether a Polyline of any type Crosses itSelf.
  ;;  With 3D Polylines, must have true intersection in 3D,
  ;;  not apparent in 2D.
  ;;  Returns T if self-crossing, nil if not.
  ;;  by Kent Cooper
  (defun polylineSelfCrossing (poly / pltyp plobj plverts plints)
    (vl-load-com)
    (setq
      pltyp (cdr (assoc 0 (entget poly)))
      plobj (vlax-ename->vla-object poly)
      plverts (length
                (safearray-value
                  (variant-value (vla-get-Coordinates plobj))))
      plints (/ (length
                  (safearray-value
                    (variant-value
                      (vla-intersectwith plobj plobj acExtendNone)))) 3)
    ); end setq
    (setq plverts (/ plverts (if (= pltyp "LWPOLYLINE") 2 3)))
    (if (vlax-curve-isClosed poly)
      (< plverts plints); then - closed
      (if (equal (vlax-curve-getStartPoint poly)
                 (vlax-curve-getEndPoint poly) 1e-8); else - open
        (<= plverts plints); then - start/end at same place
        (<= plverts (1+ plints)); else - open
      ); end if
    ); end if
  ); end defun



; Normal3Points (gile) Ret normal vector of a planeof 3 points
 (DeFun Normal3Points (p0 p1 p2)
  (Normalize (CrossProduct (mapcar '- p1 p0) (mapcar '- p2 p0))) )

; CrossProduct (gile)  two vectors (real)
 (DeFun CrossProduct (v1 v2)
  (list	(- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2)))
	(- (* (caddr v1) (car v2)) (* (car v1) (caddr v2)))
	(- (* (car v1) (cadr v2)) (* (cadr v1) (car v2)))  ) )

; Normalize (gile)  Return  single unit vector
 (DeFun Normalize (v)
  ((lambda (l)  (if (/= 0 l)  (ScaleVector v (/ 1 l))  )  )
    (distance '(0 0 0) v)  ))

; ScaleVector (gile) vector after multiplying it by a scalar
 (DeFun ScaleVector (v s) (mapcar (function (lambda (x) (* x s))) v))



(defun ucsSave ( / allUCS newUCS)  ;;be sure current UCS has a name to return to
  (setq allUCS (vla-get-UserCoordinateSystems acaddoc))
  (setq origUCS
    (vla-add allUCS
  		(vlax-3d-point (trans '(0.0 0.0 0.0) 1 0))
  		(vlax-3d-point (trans '(1.0 0.0 0.0) 1 0))
  		(vlax-3d-point (trans '(0.0 1.0 0.0) 1 0))
  		"zz_centroid_01"
	  )
  )
)

(defun setUCStoObject ( / allUCS newUCS)
  (setq pt (osnap (cadr e) "_near"))
  (setq newOrig (trans pt 1 0)) ;;pick point in WCS
  (if (or
        (eq entype "SPLINE")
        (and (eq entype "POLYLINE")(= 8 (logand 8 (cdr (assoc 70 ed)))))  ;;3Dpolyline
        )
      (progn
        (setq pt1 (vlax-curve-getPointatParam obj 1))
        (setq pt2 (vlax-curve-getPointatParam obj 2))
        (setq pt3 (vlax-curve-getPointatParam obj 3))
        (setq normal (Normal3Points pt1 pt2 pt3))
        )
      (setq normal (vlax-get obj 'Normal))
      )
  (setq allUCS (vla-get-UserCoordinateSystems acaddoc))
  (setq newUCS 
    (vla-add allUCS 
      (vlax-3D-point (trans '(0.0 0.0 0.0) normal 0))
      (vlax-3D-point (trans '(1.0 0.0 0.0) normal 0))
      (vlax-3d-point (trans '(0.0 1.0 0.0) normal 0)) 
      "zz_centroid_02"
      )
    )
;;move UCS origin to point picked on object   
  (vla-put-origin newUCS (vlax-3d-point newOrig 0 1))
  (vla-put-activeUCS acadDoc newUCS)  ;;update UCS
  )


(defun makeRegion ( entity / sa reg)
  (setq sa (vlax-make-variant
              (vlax-safearray-fill
                (vlax-make-safearray vlax-vbObject '(0 . 0))
                  (list entity)
                  )
                )
        reg (vla-addregion
              (vla-get-ModelSpace
                (vla-get-ActiveDocument
                  (vlax-get-acad-object)
                  )
                )
              sa
              )
        )
  )


;;=======main program========

  (defun myerror (msg)
    (setvar 'delobj *delobj)
    (setvar 'osmode *osmode)
    (if origUCS (vla-put-ActiveUCS acadDoc origUCS))
    (setq *error* olderror)
    )

  (setq olderror *error*)
  (setq *error* myerror)
  (setq *delobj (getvar 'delobj))
  (setvar 'delobj 0)
  (setq *osmode (getvar 'osmode))
  (setvar 'osmode 0)
  
  
;;be sure current layer is unlocked  
  (setq lay (entget (tblobjname "layer" (getvar 'clayer))))
  (setq laystatus (cdr (assoc 70 lay)))
  (if (= 4 (logand 4 laystatus))
      (progn
       (setq newLaystatus (cons 70 (- layStatus 4)))
       (setq lay (subst (cons 70 (- layStatus 4)) (assoc 70 lay) lay))
       (entmod lay)
       (entupd (cdr (assoc -1 lay)))
       )
      )  
;;and turned on  
  (setq lay (entget (tblobjname "layer" (getvar 'clayer))))
  (setq laystatus (cdr (assoc 62 lay)))
  (if (minusp laystatus)
      (progn
       (setq lay (subst (cons 62 (abs laystatus)) (assoc 62 lay) lay))
       (entmod lay)
       (entupd (cdr (assoc -1 lay)))
       )
      )  

;;be sure points show up when created
  (if (and
        (= 0 (getvar 'pdmode)) 
        (= 0 (getvar 'cmdactive))
        )
      (progn
        (setvar 'pdmode 34)
        (setvar 'pdsize 0)
        )
      )


  (setq acadObj (vlax-get-acad-object))
  (setq acadDoc (vla-get-activedocument acadObj))
  (setq *ModelSpace (vla-get-ModelSpace acadDoc))
  (ucsSave)  ;;saves origUCS to return to
  (setq prevEn (entlast))
  (setq e (entsel "Select object to find centroid: "))
  (setq en (car e) ed (entget en) entype (cdr (assoc 0 ed)) obj (vlax-ename->vla-object en))

;; always return CENTRO in current UCS coordinates for transparent use

  (cond        
    ( (and (wcmatch entype "*POLYLINE")
           (polylineSelfCrossing en)
           )
      (vlr-beep-reaction)
      (princ "\nSelected polyline is self-crossing.")  ;; and exit
      (nil)  ;; so no point is returned
      )
      
    ( (and (eq entype "SPLINE")
           (safearray-value (variant-value (vla-intersectwith obj obj acExtendNone)))
           )
      (vlr-beep-reaction)
      (princ "\nSelected spline is self-crossing.")  ;; and exit
      (nil)  ;; so no point is returned
      )
      
    ( (eq entype "CIRCLE")
      (setq centro (osnap (cadr e) "_cen"))    
      )  

    ( (eq entype "3DSOLID")
      (setq centro (trans (vlax-get obj 'centroid) 0 1)) ;;current UCS coords
       )

    ( (eq entype "REGION")
      (setUCStoObject)
      (setq centro (trans (vlax-get obj 'centroid) 1 0))
      (vla-put-ActiveUCS acadDoc origUCS)
      (setq centro (trans centro 0 1))
      )

;;for others, have to set UCS to object, create a region, 
;;get its centroid, and then delete the region
    ( (and (member entype '("ELLIPSE" "LWPOLYLINE" "POLYLINE" "SPLINE"))
           (vlax-curve-isclosed obj)
           (vlax-curve-isplanar obj) ;;okay if a flat 3Dpolyline or spline
           (vlax-curve-getarea obj)
           )
      (setUCStoObject)
      (makeRegion obj)
      (setq newEn (entlast))
      (if (not (eq prevEn newEn))
          (progn
            (setq obj (vlax-ename->vla-object newEn))
            (setq centro (vlax-get obj 'centroid))
            (setq centro (trans centro 1 0)) ;; to WCS coords
            (entdel newEn)
            )
          (progn
            (vlr-beep-reaction)
            (princ "\nCould not derive centroid.")
            )
          )
      (vla-put-ActiveUCS acadDoc origUCS)
      (setq centro (trans centro 0 1)) ;;WCS -> orig UCS
      )

  ( T
    (vlr-beep-reaction)
    (princ "\nCould not derive centroid.")
    )

      );cond

  (if
    (type centro)
    (if (= 1 (getvar 'cmdactive))
        (progn  ;;return centro in UCS coordinates for transparent use
          (myerror "msg")
          (osnap centro "_none")
          )
        (progn  ;;convert centro to WCS coordinates to create entity
          (myerror "msg")
          (vla-addPoint *ModelSpace (vlax-3d-point (trans centro 1 0)))
          )
        )
      )
;;Note: no code after (if) so that returned point is last thing evaluated
)

(defun c:ctd ()
  (C:centroid)
  )

(princ "CENTROID loaded. Either CENTROID or CTD may be used, transparently or not.")
(princ)