Trouver et marquer le centre des formes fermées

Du texte brut, rien de caché. Copiez-le dans un fichier nommé cxcentroid.lsp ou téléchargez-le.

;;; ============================================================================
;;; CXCENTROID - Find and mark the centre of closed shapes
;;; Version 1.0.0
;;; CADXChange LISP tools - https://cadxchange.net/resources/lisp/cxcentroid
;;; Tested in: AutoCAD (full version). Other programs that run AutoLISP may work but are not tested.
;;; Copyright (c) CADXChange. Free for personal and commercial use; do not resell or
;;; republish it as a collection. Terms: https://cadxchange.net/legal/lisp-terms
;;; ============================================================================

(defun c:CXCENTROID ( / *error* cx:sv ss pts size prec)
  (setq *error* cx:err)
  (if (setq ss (cx:pick "\nSelect closed polylines, circles or ellipses: " '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE"))))
    (progn
      (setq pts  (cx:centroid-run (cx:ss->list ss))
            prec (getvar "LUPREC"))
      (foreach p pts (princ (strcat "\nCentroid: " (cx:num (car p) prec) ", " (cx:num (cadr p) prec))))
      (if (and pts (= (cx:ask-kw "Mark the centroids with a cross" "Yes No" "Yes") "Yes"))
        (progn
          (setq size (cx:ask-real "Size of the cross" (* 2.0 (getvar "TEXTSIZE"))))
          (cx:start '(("CMDECHO" . 0)))
          (foreach p pts (cx:cross p size (getvar "CLAYER")))
          (cx:end)))
      (if (null pts) (princ "\nNo closed objects in the selection."))))
  (princ))


;;; ---- Shared helpers (used by the command above; identical in every CADXChange tool) ----

;; Close the undo step and put the system variables back.
(defun cx:end ()
  (foreach v cx:sv (setvar (car v) (cdr v)))
  (command "_.UNDO" "_End")
  (setq cx:sv nil)
  (princ))

;; Error handler: restores everything, stays quiet on Esc.
(defun cx:err (msg)
  (if (> (getvar "CMDACTIVE") 0) (command))
  (cx:end)
  (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
    (princ (strcat "\nError: " msg)))
  (princ))

;; Use the objects already selected, or ask the user to select; FILTER is an ssget filter list or nil.
(defun cx:pick (msg filter / ss)
  (setq ss (if filter (ssget "_I" filter) (ssget "_I")))
  (if (null ss)
    (progn
      (princ msg)
      (setq ss (if filter (ssget filter) (ssget)))))
  ss)

(defun cx:dxf (code ed)
  (cdr (assoc code ed)))

;; True for a closed polyline, a circle and a full ellipse.
(defun cx:ent-closed (ed / type)
  (setq type (cx:dxf 0 ed))
  (cond
    ((= type "LWPOLYLINE") (= 1 (logand 1 (cx:dxf 70 ed))))
    ((= type "CIRCLE") T)
    ((= type "ELLIPSE") (< (abs (- (- (cx:dxf 42 ed) (cx:dxf 41 ed)) (* 2.0 pi))) 1e-6))))

;; The arc a bulge makes between P1 and P2 as (center-x center-y radius start-angle sweep), or nil for a straight segment.
;; The sweep is signed: positive turns counter-clockwise.
(defun cx:bulge-arc (p1 p2 b / theta dx dy len nx ny d ccx ccy)
  (if (< (abs b) 1e-9)
    nil
    (progn
      (setq theta (* 4.0 (atan b))
            dx    (- (car p2) (car p1))
            dy    (- (cadr p2) (cadr p1))
            len   (sqrt (+ (* dx dx) (* dy dy))))
      (if (< len 1e-12)
        nil
        (progn
          (setq nx  (/ (- dy) len)
                ny  (/ dx len)
                d   (/ (/ len 2.0) (/ (sin (/ theta 2.0)) (cos (/ theta 2.0))))
                ccx (+ (/ (+ (car p1) (car p2)) 2.0) (* nx d))
                ccy (+ (/ (+ (cadr p1) (cadr p2)) 2.0) (* ny d)))
          (list ccx ccy (/ len (* 2.0 (sin (/ (abs theta) 2.0))))
                (atan (- (cadr p1) ccy) (- (car p1) ccx)) theta))))))

;; The centroid of a closed polyline with its arc segments, and its area: ((x y) area).
(defun cx:lw-centroid (verts / n i v1 v2 a f ap sx sy seg dd mid)
  (setq n (length verts) i 0 ap 0.0 sx 0.0 sy 0.0)
  ;; the polygon through the vertices
  (repeat n
    (setq v1 (nth i verts)
          v2 (nth (rem (1+ i) n) verts)
          f  (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))
          ap (+ ap (/ f 2.0))
          sx (+ sx (/ (* (+ (car v1) (car v2)) f) 6.0))
          sy (+ sy (/ (* (+ (cadr v1) (cadr v2)) f) 6.0)))
    (setq i (1+ i)))
  ;; plus the circular segment of every arc
  (setq i 0)
  (repeat n
    (setq v1 (nth i verts)
          v2 (nth (rem (1+ i) n) verts)
          a  (cx:bulge-arc v1 v2 (nth 2 v1)))
    (if a
      (progn
        (setq seg (* 0.5 (nth 2 a) (nth 2 a) (- (nth 4 a) (sin (nth 4 a))))
              dd  (/ (* 4.0 (nth 2 a) (expt (sin (/ (nth 4 a) 2.0)) 3)) (* 3.0 (- (nth 4 a) (sin (nth 4 a)))))
              mid (+ (nth 3 a) (/ (nth 4 a) 2.0))
              ap  (+ ap seg)
              sx  (+ sx (* seg (+ (car a) (* dd (cos mid)))))
              sy  (+ sy (* seg (+ (cadr a) (* dd (sin mid))))))))
    (setq i (1+ i)))
  (if (< (abs ap) 1e-12)
    (list (list (car (car verts)) (cadr (car verts))) 0.0)
    (list (list (/ sx ap) (/ sy ap)) (abs ap))))

;; The vertices of an LWPOLYLINE entity list as ((x y bulge start-width end-width) ...).
(defun cx:lw-verts (ed / out cur)
  (foreach g ed
    (cond
      ((= (car g) 10)
       (if cur (setq out (cons cur out)))
       (setq cur (list (cadr g) (caddr g) 0.0 0.0 0.0)))
      ((and cur (= (car g) 40)) (setq cur (list (nth 0 cur) (nth 1 cur) (nth 2 cur) (cdr g) (nth 4 cur))))
      ((and cur (= (car g) 41)) (setq cur (list (nth 0 cur) (nth 1 cur) (nth 2 cur) (nth 3 cur) (cdr g))))
      ((and cur (= (car g) 42)) (setq cur (list (nth 0 cur) (nth 1 cur) (cdr g) (nth 3 cur) (nth 4 cur))))))
  (if cur (setq out (cons cur out)))
  (reverse out))

;; The centroid of every closed polyline (arcs included), circle and full ellipse in NAMES: ((x y) ...).
(defun cx:centroid-run (names / out ed)
  (foreach e names
    (setq ed (entget e))
    (cond
      ((not (cx:ent-closed ed)))
      ((= (cx:dxf 0 ed) "LWPOLYLINE") (setq out (cons (car (cx:lw-centroid (cx:lw-verts ed))) out)))
      (T (setq out (cons (list (car (cx:dxf 10 ed)) (cadr (cx:dxf 10 ed))) out)))))
  (reverse out))

;; Selection set to a list of entity names.
(defun cx:ss->list (ss / i out)
  (setq i 0)
  (if ss
    (repeat (sslength ss)
      (setq out (cons (ssname ss i) out)
            i   (1+ i))))
  (reverse out))

;; Real X as text with at most PREC decimals and no trailing zeros ("2.50" -> "2.5", "3.00" -> "3").
(defun cx:num (x prec / s)
  (setq s (rtos x 2 prec))
  (if (wcmatch s "*.*")
    (progn
      (while (= (substr s (strlen s)) "0") (setq s (substr s 1 (1- (strlen s)))))
      (if (= (substr s (strlen s)) ".") (setq s (substr s 1 (1- (strlen s)))))))
  (if (or (= s "-0") (= s "")) "0" s))

;; Replace every OLD in STR by NEW (case sensitive).
(defun cx:replace (str old new / n out pos)
  (setq n (strlen old) out "" pos 1)
  (if (= n 0)
    str
    (progn
      (while (<= pos (1+ (- (strlen str) n)))
        (if (= (substr str pos n) old)
          (setq out (strcat out new) pos (+ pos n))
          (setq out (strcat out (substr str pos 1)) pos (1+ pos))))
      (strcat out (substr str pos)))))

;; Ask for one of the keywords in BITS ("Yes No"), default DEF; returns the keyword.
(defun cx:ask-kw (msg bits def / v)
  (initget 0 bits)
  (setq v (getkword (strcat "\n" msg " [" (cx:replace bits " " "/") "] <" def ">: ")))
  (if v v def))

(defun cx:ask-real (msg def / v)
  (setq v (getreal (strcat "\n" msg " <" (cx:num def 6) ">: ")))
  (if v v def))

;; Save the system variables in VARS ((name . value) ...), set them, and open one undo step.
;; The caller declares cx:sv as a local so the saved values live exactly as long as the command.
(defun cx:start (vars)
  (setq cx:sv (mapcar (function (lambda (v) (cons (car v) (getvar (car v))))) vars))
  (command "_.UNDO" "_Begin")
  (foreach v vars (setvar (car v) (cdr v)))
  (princ))

;; A small cross of two lines, SIZE long, centered on PT.
(defun cx:cross (pt size layer / h)
  (setq h (/ size 2.0))
  (entmakex (list '(0 . "LINE") (cons 8 layer) (list 10 (- (car pt) h) (cadr pt) 0.0) (list 11 (+ (car pt) h) (cadr pt) 0.0)))
  (entmakex (list '(0 . "LINE") (cons 8 layer) (list 10 (car pt) (- (cadr pt) h) 0.0) (list 11 (car pt) (+ (cadr pt) h) 0.0))))

(princ "\nCXCENTROID loaded. Type CXCENTROID to start.")
(princ)

Autres commandes : Mesure et polylignes

• CXAREAÉcrire la surface à l'intérieur des formes fermées
• CXLENÉcrire la longueur le long des lignes, arcs et polylignes
• CXSUMTotaliser longueur et surface par calque
• CXDISTMesurer un parcours point par point
• CXPLCLOSEFermer les polylignes dont les extrémités se touchent presque
• CXPLREVInverser le sens des lignes et polylignes
• CXPLCLEANSupprimer les sommets en double et alignés
• CXPLWIDTHDonner une même largeur à de nombreuses polylignes
• CXJOINJoindre lignes et arcs en polylignes, avec tolérance d'écart