全部明经币求一个求交点个数统计完美程序

flytoday02

求:各种颜色的线与柱层、墙层交点个数有几个...并输出EXL

langjs

嗯，你说的也有道理，如果图比杂乱还是选择比较好

(defun c:aa (/ ch co color e1 e2 ent ent1 file_id file_idx i j la la1 lst lst1 name name1 pt0 pt1 pt2 pt3 pt4 r ss ss1 x)
  (setvar "cmdecho" 0)
  (setq name (car (entsel "\n指定线所在图层:"))
        la (assoc 8 (entget name))
        lst1 '()
        ss1 (ssadd)
  )
  (princ (strcat " <" (cdr la) ">"))
  (redraw name 3)
  (setq ss1 (ssadd name ss1))
  (princ "\n选择与线相交的样本:")
  (setvar "nomutt" 1)
  (while (setq name1 (car (entsel)))
    (if (and
          name1
          (setq la1 (assoc 8 (entget name1)))
          (not (equal la la1))
          (not (member (cdr la1) lst1))
        )
      (progn
        (princ (strcat " <" (cdr la1) ">"))
        (setq lst1 (cons (cdr la1) lst1))
        (redraw name1 3)
        (setq ss1 (ssadd name1 ss1))
      )
    )
  )
  (repeat (setq i (sslength ss1))
    (redraw (ssname ss1 (setq i (1- i))) 4)
  )
  (princ "\n框选计算范围:")
  (setq ss (ssget (list '(0 . "LINE,ARC") la))
        color '((1 . "红线") (2 . "黄线")
         (3 . "绿线")
         (4 . "青线")
         (5 . "蓝线")
         (6 . "洋红线")
         (7 . "白线")
        )
        lst '()
  )
  (setvar "nomutt" 0)
  (repeat (setq i (sslength ss))
    (setq name (ssname ss (setq i (1- i)))
          ent (entget name)
    )
    (if (= (cdr (assoc 0 ent)) "LINE")
      (setq pt1 (cdr (assoc 10 ent))
            pt2 (cdr (assoc 11 ent))
      )
      (setq pt0 (cdr (assoc 10 ent))
            r (cdr (assoc 40 ent))
            pt1 (polar pt0 (cdr (assoc 50 ent)) r)
            pt2 (polar pt0 (cdr (assoc 51 ent)) r)
      )
    )
    (setq pt3 (polar pt1 (angle pt1 pt2) (+ (distance pt1 pt2) 10))
          pt4 (polar pt2 (angle pt2 pt1) (+ (distance pt2 pt1) 10))
    )
    (if (not (assoc 62 ent))
      (setq co (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 ent))))))
      (setq co (cdr (assoc 62 ent)))
    )
    (setq co (cdr (assoc co color)))
    (setq ss1 (ssget "F" (list pt3 pt4)))
    (if (ssmemb name ss1)
      (setq ss1 (ssdel name ss1))
    )
    (repeat (setq j (sslength ss1))
      (setq name1 (ssname ss1 (setq j (1- j))))
      (setq ent1 (entget name1)
            la1 (cdr (assoc 8 ent1))
            ch (strcat co "与" la1 "层交点")
      )
      (if (member la1 lst1)
        (progn
          (if (/= (cdr la) la1)
            (if (assoc ch lst)
              (setq lst (subst
                          (cons ch (1+ (cdr (assoc ch lst))))
                          (assoc ch lst)
                          lst
                        )
              )
              (setq lst (cons (cons ch 1) lst))
            )
          )
        )
      )
    )
  )
  (setq lst (vl-sort lst '(lambda (e1 e2)
                            (< (car e1) (car e2))
                          )
            )
  )
  (setq file_idx (getfiled "指定输出文件路径" "" "xls" 1)
        file_id (open file_idx "w")
  )
  (foreach x lst
    (write-line (strcat (car x) "\t" (itoa (cdr x)) "\t" "个") file_id)
    (princ (strcat "\n " (car x) " " (itoa (cdr x)) " " "个"))
  )
  (close file_id)
  (princ)
)

Andyhon

照说还得补上 *.Xls 共构成完整的调试附件

flytoday

Andyhon 发表于 2012-4-30 12:55
照说还得补上 *.Xls 共构成完整的调试附件

kkk3kkk

用軸線...就可以有交点......

flytoday

kkk3kkk 发表于 2012-4-30 13:40
用軸線...就可以有交点......

这个可能只有高手中滴高手能解

顶起.

langjs

不怕做不到，就怕想不到


源码在这里
(defun c:aa (/ ch co color e1 e2 ent ent1 file_id file_idx i j la la1 lst name name1 pt0 pt1 pt2 pt3 pt4 r ss ss1 x)
  (setvar "cmdecho" 0)
  (setq name (car (entsel "\n选择样本取得图层:")))
  (setq la (assoc 8 (entget name)))
  (princ (strcat " < " (cdr la) " > "))
  (redraw name 3)
  (setq ss (ssget (list '(0 . "LINE,ARC") la))
        color '((1 . "红线") (2 . "黄线")
         (3 . "绿线")
         (4 . "青线")
         (5 . "蓝线")
         (6 . "洋红线")
         (7 . "白线")
        )
        lst '()
  )
  (redraw name 4)
  (repeat (setq i (sslength ss))
    (setq name (ssname ss (setq i (1- i)))
          ent (entget name)
    )
    (if (= (cdr (assoc 0 ent)) "LINE")
      (setq pt1 (cdr (assoc 10 ent))
            pt2 (cdr (assoc 11 ent))
      )
      (setq pt0 (cdr (assoc 10 ent))
            r (cdr (assoc 40 ent))
            pt1 (polar pt0 (cdr (assoc 50 ent)) r)
            pt2 (polar pt0 (cdr (assoc 51 ent)) r)
      )
    )
    (setq pt3 (polar pt1 (angle pt1 pt2) (+ (distance pt1 pt2) 10))
          pt4 (polar pt2 (angle pt2 pt1) (+ (distance pt2 pt1) 10))
    )
    (if (not (assoc 62 ent))
      (setq co (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 ent))))))
      (setq co (cdr (assoc 62 ent)))
    )
    (setq co (cdr (assoc co color)))
    (setq ss1 (ssget "F" (list pt3 pt4)))
    (if (ssmemb name ss1)
      (setq ss1 (ssdel name ss1))
    )
    (repeat (setq j (sslength ss1))
      (setq name1 (ssname ss1 (setq j (1- j)))
            ent1 (entget name1)
            la1 (cdr (assoc 8 ent1))
            ch (strcat co "与" la1 "层交点")
      )
      (if (/= (cdr la) la1)
        (if (assoc ch lst)
          (setq lst (subst
                      (cons ch (1+ (cdr (assoc ch lst))))
                      (assoc ch lst)
                      lst
                    )
          )
          (setq lst (cons (cons ch 1) lst))
        )
      )
    )
  )
  (setq lst (vl-sort lst '(lambda (e1 e2)
                            (< (car e1) (car e2))
                          )
            )
  )
  (setq file_idx (getfiled "指定输出文件路径" "" "xls" 1)
        file_id (open file_idx "w")
  )
  (foreach x lst
    (write-line (strcat (car x) "\t" (itoa (cdr x)) "\t" "个") file_id)
    (princ (strcat "\n " (car x) " " (itoa (cdr x)) " " "个"))
  )
  (close file_id)
  (princ)
)

flytoday

langjs 发表于 2012-4-30 22:40
不怕做不到，就怕想不到

langjs 老师那个交点是这样子算的哈
能不改成这样..就是先指定样本图层..分别指定..样本图层.线.柱.墙....这三个样本图层后再选择对象..

老师你这个程序..只指定一个样本图层后就好象选择...

选择样本取得图层: < 墙 >
选择对象: 指定对角点: 找到 0 个
选择对象: 指定对角点: 找到 0 个，总计 0 个
选择对象:
; 错误: 参数类型错误: lselsetp nil

但是如果先选择线..好象会对.

flytoday

我先选择指定线层..墙柱层是默认的啊..不是指定的哦老师

flytoday

flytoday 发表于 2012-4-30 22:58
langjs 老师那个交点是这样子算的哈
能不改成这样..就是先指定样本图层..分别指定..样本图层.线.柱.墙 ...

那老师..我也想指定下墙.柱层啊..这样更好