← back to paste›Edit / fork

Untitled paste

#8JHsQrMhzupublic / publicnew version

anonymous created 6 days ago Expires in 19 hours 4.4 KB syntax: plaintext

Your changes create a new paste linked to this one — the original is untouched.

new version Your changes create a new paste linked to this one — the original is untouched.

Visibility Public feed Access public

Change note (optional)

This paste will be listed on the public feed. Change Visibility if you only want people with the link to see it.

Cancel

;;;===========================================================
;;;  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