← retour au collage›Modifier / dupliquer

Collage sans titre

#8JHsQrMhzupublic / publicnouvelle version

anonyme créé 6 days ago Expire dans 19 hours 4.4 KB syntaxe: plaintext

Vos changements créent un nouveau collage lié à celui-ci — l’original reste intact.

nouvelle version Vos changements créent un nouveau collage lié à celui-ci — l’original reste intact.

Visibilité Fil public Accès public

Note de changement (facultatif)

Ce collage sera affiché dans le fil public. Changez la visibilité si vous voulez seulement le partager par lien.

Annuler

;;;===========================================================
;;;  Multi-Region Circle Counter  v6.0
;;;  Command: JMKTJ
;;;  Output: CSV file (open with Excel)
;;;===========================================================

(defun c:JMKTJ (/ ss ssb ssc sst regs res i e et pts obj cen rad
               dlist txt pt fname fp line)

(setvar "cmdecho" 0)

(princ "\nSelect all objects: ")
  (setq ss (ssget))
  (if (null ss) (progn (princ "\nNothing selected!") (exit)))

(setq ssb (ssadd) ssc (ssadd) sst (ssadd))
  (setq i 0)
  (repeat (sslength ss)
    (setq e (ssname ss i))
    (setq et (cdr (assoc 0 (entget e))))
    (cond
      ((member et '("LINE" "LWPOLYLINE" "POLYLINE" "ELLIPSE" "SPLINE" "ARC"))
        (ssadd e ssb))
      ((= et "CIRCLE")
        (ssadd e ssb)
        (ssadd e ssc))
      ((member et '("TEXT" "MTEXT"))
        (ssadd e sst))
    )
    (setq i (1+ i))
  )

(if (< (sslength ssb) 1) (progn (princ "\nNo boundary!") (exit)))
  (if (< (sslength ssc) 1) (progn (princ "\nNo circle!") (exit)))
  (if (< (sslength sst) 1) (progn (princ "\nNo text!") (exit)))

;; Build region point lists
  (setq regs '())
  (setq i 0)
  (repeat (sslength ssb)
    (setq e (ssname ssb i))
    (setq et (cdr (assoc 0 (entget e))))
    (setq pts '())

(cond
      ((= et "LINE")
        (setq pts (list (cdr (assoc 10 (entget e)))
                        (cdr (assoc 11 (entget e))))))

((or (= et "LWPOLYLINE") (= et "POLYLINE"))
        (setq obj (vlax-ename->vla-object e))
        (setq n (fix (vlax-curve-getEndParam obj)))
        (setq j 0)
        (while (<= j n)
          (setq pt (vlax-curve-getPointAtParam obj j))
          (if pt (setq pts (append pts (list pt))))
          (setq j (1+ j))))

((= et "CIRCLE")
        (setq obj (vlax-ename->vla-object e))
        (setq cen (vlax-get obj 'Center))
        (setq rad (vlax-get obj 'Radius))
        (setq j 0)
        (while (< j 36)
          (setq pt (list (+ (car cen) (* rad (cos (* j 0.1745))))
                         (+ (cadr cen) (* rad (sin (* j 0.1745)))) 0))
          (setq pts (append pts (list pt)))
          (setq j (1+ j))))

((= et "ELLIPSE")
        (setq obj (vlax-ename->vla-object e))
        (setq cen (vlax-get obj 'Center))
        (setq ma (vlax-get obj 'MajorAxis))
        (setq mi (vlax-get obj 'MinorAxis))
        (setq ml (sqrt (+ (* (car ma) (car ma)) (* (cadr ma) (cadr ma)))))
        (setq sl (sqrt (+ (* (car mi) (car mi)) (* (cadr mi) (cadr mi)))))
        (setq j 0)
        (while (< j 36)
          (setq pt (list (+ (car cen) (* ml (cos (* j 0.1745))))
                         (+ (cadr cen) (* sl (sin (* j 0.1745)))) 0))
          (setq pts (append pts (list pt)))
          (setq j (1+ j))))

((= et "SPLINE")
        (setq obj (vlax-ename->vla-object e))
        (setq sp (vlax-curve-getStartParam obj))
        (setq ep (vlax-curve-getEndParam obj))
        (setq j 0)
        (while (<= j 50)
          (setq pt (vlax-curve-getPointAtParam obj (+ sp (* j (/ (- ep sp) 50)))))
          (if pt (setq pts (append pts (list pt))))
          (setq j (1+ j))))

((= et "ARC")
        (setq obj (vlax-ename->vla-object e))
        (setq cen (vlax-get obj 'Center))
        (setq rad (vlax-get obj 'Radius))
        (setq sa (vlax-get obj 'StartAngle))
        (setq ea (vlax-get obj 'EndAngle))
        (setq j 0)
        (while (<= j 20)
          (setq pt (list (+ (car cen) (* rad (cos (+ sa (* j (/ (- ea sa) 20))))))
                         (+ (cadr cen) (* rad (sin (+ sa (* j (/ (- ea sa) 20)))))) 0))
          (setq pts (append pts (list pt)))
          (setq j (1+ j))))
    )

(if (> (length pts) 2)
      (setq regs (append regs (list pts))))
    (setq i (1+ i))
  )

;; Point in polygon
  (defun pip (pt pts / in i j xi yi xj yj)
    (setq in nil i 0 j (1- (length pts)))
    (while (< i (length pts))
      (setq xi (car (nth i pts)) yi (cadr (nth i pts)))
      (setq xj (car (nth j pts)) yj (cadr (nth j pts)))
      (if (and (or (> yi (cadr pt)) (> yj (cadr pt)))
               (or (< yi (cadr pt)) (< yj (cadr pt)))
               (or (< xi (car pt)) (< xj (car pt))))
        (if (< xi (+ (* (- (car pt) xi) (/ (- yj yi) (- xj xi))) (car pt)))
          (setq in (not in))))
      (setq j i i (1+ i)))
    in)

;; Process each region
  (setq res '())
  (foreach rg regs
    (setq dlist '() i 0)
    (repeat (sslength ssc)
      (setq e (ssname ssc i))
      (setq cen (cdr (assoc 10 (entget e))))
      (if (pip