← 返回文本›编辑 / 分支

无标题文本

#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