← ペーストに戻る›編集 / フォーク

無題のペースト

#8JHsQrMhzupublic / public新しいバージョン

匿名作成日 6 days ago 失効まで 19 hours 4.4 KB 構文: plaintext

変更により、このペーストにリンクされた新しいペーストが作成されます — 元のペーストは変更されません。

新しいバージョン 変更により、このペーストにリンクされた新しいペーストが作成されます — 元のペーストは変更されません。

可視性パブリックフィードアクセス public

変更メモ (任意)

このペーストはパブリックフィードに表示されます。リンクを知っている人だけに見せたい場合は可視性を変更してください。

キャンセル

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