统计圆的交集次数及填充

bbswen · 发表于 2014-8-29 15:56:27

高手莫笑，

经过几天的拼凑，终于算是可以小有长劲了，呵呵，测试图，时间1.9秒。

应该还可以提高，已经起过我的能力了，呵呵，

csharp · 发表于 2014-8-29 15:59:23

bbswen 发表于 2014-8-29 15:56
高手莫笑，

经过几天的拼凑，终于算是可以小有长劲了，呵呵，测试图，时间1.9秒。

把代码贴上来啊

bbswen · 发表于 2014-8-29 16:04:58

先上图看下，

bbswen · 发表于 2014-8-29 16:11:14

请大大门指点一下，精简一下，
再帮我扩展下，
大圆外不统计，
不同颜色的面积统计。
嘿嘿，多多指教，下面贴源码，莫笑。

(defun c:tte (/ e pts ss d lst s1 s2 lst1 cl nl lst2 hl)
(if (and (setq e (car (xdrx_entsel
"\nPick Curve: "
'((0 . "*Polyline,CIRCLE,ELLIPSE,SPLINE"))
)
);拾取一个曲线
)
(vlax-curve-isclosed e) ;确定指定曲线是否闭合（即起点与端点是否重合）
(setq pts (xdrx_getsamplept e));;得到这个曲线的模拟顶点表
(setq ss (ssget "WP" pts '((0 . "CIRCLE"))));根据圈围选定对像创建选择集
(setq d (getdist "\nRadius: "))
(setq t0 (xdl-getutime))
)
(progn
(setq lst (mapcar
'(lambda (x / p)
(setq p (xdrx_getpropertyvalue x "Center"));实体属性获取 (p 圆心)
(setq cl (cons (xdrx_circle_make p d) cl));创建圆实体
p
)
(xdrx_pickset->ents ss);选择集中的实体表
)
lst1 (cons (ssname (xdrx_entity_copy e) 0) cl) ;实体拷贝
sm (XD::Entity->Pickset lst1)
)
;(mbb);交点打断
(setq
;s1 (xdrx_curve_intersectbreak (XD::Entity->Pickset lst1) 0);将选择集中的曲线在所有交点处break
;s1 (setq ss (ssget "WP" pts '((0 . "arc"))))
slst (mbb)
s1 (XD::Entity->Pickset slst)
s2 (xdrx_geom_searchregions s1 0);求给定选择集内的实体的连通区域所有边界
lst2 (xdrx_pickset->ents s2);选择集中的实体表
lst2 (vl-sort lst2 ;根据给定的比较函数来对表中的元素排序
'(lambda (x1 x2)
(> (car (xdrx_getarea x1));求AutoCAD AcDbCurve(曲线)类的面积和周长(长度)
(car (xdrx_getarea x2))
)
)
)
)
(xdrx_entity_delete (car lst2));删除当前空间或者块定义中的实体
(setq
nl (mapcar
'(lambda (x / p)
(if (setq
p
(cadr (assoc "Centroid" (xdrx_curve_info x)));获得AcDbCurve曲线实体(polyline,lwpolyline,arc,circle,ellipse,spline) 和AcDbRegion(REGION面域)实体的面积，周长，质心，惯性矩，回转半径，边界盒等信息。
)
(list
(length
(vl-remove nil
(mapcar '(lambda (a)
(if (< (distance p a) d)
t
nil
)
)
lst;->a
)
)
)
x
)
)
)
(cdr lst2)
)
)
(mapcar
'(lambda (x / ent)
(setq ent (xdrx_hatch_make (cadr x)));创建HATCH填充实体
(setq hl (cons ent hl))
(if (zerop (car x));查验是否是0
(xdrx_entity_setcolor ent 15);设置一个实体的颜色
(xdrx_entity_setcolor ent (car x))
)
)
(vl-remove nil nl)
)
(apply 'xdrx_draworder->back hl);将参数实体和选择集的任意组合的实体顺序放到最后面
)
)
(princ (strcat "\n*****""耗时"
(rtos (- (xdl-getutime)t0)2 3)
"秒"
))
(princ)
)
(defun XD::Entity->PickSet (entl / n ss x)
(setq ss (ssadd))
(foreach n entl
(ssadd n ss)
)
ss
)
(defun xdl-getutime()
(* 86400 (getvar "tdusrtimer")
)
)
;;交点打断主函数
(defun MBB (/ elist ssg n t0 lst)
(setq lst '()) ;empty list
(VL-LOAD-COM)
(fy:clearcset)
;;; (setq t0 (xdl-getutime))
(if ;(setq ssg (ssget '((0 . "line,arc,circle,ellipse"))))
(setq ssg sm)
(progn
(command "_.select" ssg "")
(vlax-for obj (vla-get-activeselectionset
(vla-get-activedocument (vlax-get-acad-object))
)
(setq elist (cons obj elist)) ; ssg->elist
)
)
)
(setq lst (DoEntMake (InterSort (ssinter elist))))
(princ)
lst
)
;;求交点集函数－nth
;;经过测试，nth函数仅比assoc函数快一点点。
;;故此函数也可取消i，j变量，直接使用assoc函数
(defun ssinter (el / el1 obj1 obj2 ipts pts list1 outlst i j)
(setq outlst (mapcar 'list el)
i -1 ;obj1位置指针
n 0 ;交点数计数器
)
(while el
(setq obj1 (car el)
list1 (nth (setq i (1+ i)) outlst) ;obj1已有的交点列表
el (cdr el)
el1 el
j i ;obj2位置指针
)
(while el1
(setq obj2 (car el1)
el1 (cdr el1)
j (1+ j)
)
;;取交点
(if (and (setq ipts (vla-intersectwith obj1 obj2 0))
(setq ipts (vlax-variant-value ipts))
(> (vlax-safearray-get-u-bound ipts 1) 0)
)
(progn
(setq ipts (vlax-safearray->list ipts)
pts '() ;obj1,obj2交点临时列表变量
)
(while (> (length ipts) 0)
(setq pts (cons (list (car ipts)
(cadr ipts)
(caddr ipts)
)
pts
)
ipts (cdddr ipts)
)
)
(setq list1 (append list1 pts) ;存obj1交点表，循环结束后再更新
n (+ n (length pts)) ;交点计数累加
)
;;obj2的交点列表立即更新
(setq
outlst (subst (append (nth j outlst) pts)
(nth j outlst)
outlst
)
)
)
)
)
;;当obj1存在交点，且非封闭曲线，添加两端点
(if (and (cdr list1) (not (vlax-curve-isClosed obj1)))
(setq list1 (append list1
(list (vlax-curve-getEndPoint obj1))
(list (vlax-curve-getStartPoint obj1))
)
)
)
(setq outlst (subst list1 (nth i outlst) outlst)) ;更新obj1交点列表
)
outlst
)
;;点集排序及删除重复点函数
(defun InterSort (el / obj1 pts plst outlst)
(setq outlst '()) ;empty list
(foreach item el
(setq obj1 (car item)
pts (cdr item)
plst '() ;empty list
)
(if pts ;若无交点，则不修改该实体
(progn
;;交点排序，列表为逆序
(setq
pts (vl-sort
pts
(function (lambda (p1 p2)
(< (vlax-curve-getParamAtPoint obj1 p1)
(vlax-curve-getParamAtPoint obj1 p2)
)
)
)
)
)
;;剔除重复点并将列表顺序转正
(foreach p pts
(if plst
(if (not (equal p (car plst) 0.00001))
(setq plst (cons p plst))
)
(setq plst (cons p plst))
)
)
;;闭合曲线需再添加首个交点以使新实体完全封闭
(if (vlax-curve-isClosed obj1)
(setq plst (cons (last plst) plst))
)
(setq plst (cons (vlax-vla-object->ename obj1) plst)
outlst (cons plst outlst)
)
)
)
)
outlst
)
;;调用entmake生成新实体
(defun DoEntMake (el / obj objlst objname objcen objratio objaxis outlst)
(setq outlst '()) ;empty list
(foreach e el
(setq obj (car e)
objlst (entget obj)
objlst (vl-remove (assoc -1 objlst) objlst) ;去除图元名
objlst (vl-remove (assoc 330 objlst) objlst) ;去除id
objlst (vl-remove (assoc 5 objlst) objlst) ;去除句柄
objname (cdr (assoc 0 objlst))
)
(cond
((= objname "LINE")
(repeat (- (length e) 2)
(setq e (cdr e))
(setq objlst (subst (cons 10 (car e)) (assoc 10 objlst) objlst))
(setq objlst (subst (cons 11 (cadr e)) (assoc 11 objlst) objlst)
)
(entmake objlst)
(setq outlsttem (entmakex objlst)
outlst (cons outlsttem outlst)
)
)
(entdel obj)
)
((= objname "CIRCLE")
(setq objcen (cdr (assoc 10 objlst)))
(setq objlst (subst (cons 0 "ARC") (assoc 0 objlst) objlst))
(setq objlst (append objlst
(list (cons 100 "AcDbArc")
(cons 50 0.0)
(cons 51 0.0)
)
)
)
(repeat (- (length e) 2)
(setq e (cdr e))
(setq objlst (subst (cons 50 (angle objcen (cadr e)))
(assoc 50 objlst)
objlst
)
)
(setq objlst (subst (cons 51 (angle objcen (car e)))
(assoc 51 objlst)
objlst
)
)
(entmake objlst)
(setq outlsttem (entmakex objlst)
outlst (cons outlsttem outlst)
)
)
(entdel obj)
)
((= objname "ARC")
(setq objcen (cdr (assoc 10 objlst)))
(repeat (- (length e) 2)
(setq e (cdr e))
(setq objlst (subst (cons 50 (angle objcen (cadr e)))
(assoc 50 objlst)
objlst
)
)
(setq objlst (subst (cons 51 (angle objcen (car e)))
(assoc 51 objlst)
objlst
)
)
(entmake objlst)
(setq outlsttem (entmakex objlst)
outlst (cons outlsttem outlst)
)
)
(entdel obj)
)
((= objname "ELLIPSE")
;;椭圆圆心
(setq objcen (cdr (assoc 10 objlst)))
;;相对于中心的长轴矢量
(setq objaxis (cdr (assoc 11 objlst)))
;;短轴与长轴的比例
(setq objratio (cdr (assoc 40 objlst)))
(repeat (- (length e) 2)
(setq e (cdr e))
(setq objlst (subst (cons 41 (pt->param (cadr e) objcen objaxis objratio))
(assoc 41 objlst)
objlst
)
)
(setq objlst (subst (cons 42 (pt->param (car e) objcen objaxis objratio))
(assoc 42 objlst)
objlst
)
)
(entmake objlst)
(setq outlsttem (entmakex objlst)
outlst (cons outlsttem outlst)
)
)
(entdel obj)
)
)
)
outlst
)
;;计算耗时
(defun xdl-getutime ()
(* 86400 (getvar "tdusrtimer"))
)
;;求椭圆曲线参数
(defun pt->param (pt cen axis ratio / ang param)
(setq ang (- (angle cen pt) (angle '(0. 0. 0.) axis)))
(cond ((= (cos ang) 0.0) ;防止分母cos为零出错
(if (> (sin ang) 0.0)
(setq param (* 0.5 PI))
(setq param (* 1.5 PI))
)
)
((= (sin ang) 0.0)
(if (> (cos ang) 0.0)
(setq param 0.0)
(setq param PI)
)
)
(T
(setq param (atan (/ (sin ang) (* (cos ang) ratio))))
(if (< (cos ang) 0.0)
(setq param (+ pi param))
)
)
)
param
)
(princ)
(defun fy:acapp nil
(eval (list 'defun
'fy:acapp
'nil
(vlax-get-acad-object)
)
)
(fy:acapp)
)
(defun fy:docs nil
(eval (list 'defun
'fy:docs
'nil
(vla-get-documents (fy:acapp))
)
)
(fy:docs)
)
(defun Fy:acDoc nil
(eval (list 'defun
'FY:acdoc
'nil
(vla-get-activedocument (vlax-get-acad-object))
)
)
(fy:acdoc)
)
(defun fy:acsets nil
(eval (list 'defun
'fy:acsets
'nil
(vla-get-Selectionsets (fy:acdoc))
)
)
(fy:acsets)
)
;; From eachy
(defun fy:Clearcset (/ cset)
(if (not (vl-catch-all-error-p
(setq cset
(vl-catch-all-apply
'vla-item
(list
(fy:acsets)
"CURRENT"
)
)
)
)
)
(vla-delete cset)
)
(princ)
)
(defun fy:cset ()
(vla-get-activeselectionset (fy:acdoc))
)
(defun fy:cset->objs (/ ol)
(vlax-for obj (fy:cset)
(setq ol (cons obj ol))
)
(reverse ol)
)

(defun c:tte (/ e pts ss d lst s1 s2 lst1 cl nl lst2 hl) 
  (if (and (setq e (car        (xdrx_entsel 
                          "\nPick Curve: " 
                          '((0 . "*Polyline,CIRCLE,ELLIPSE,SPLINE")) 
                        ) 
                   );拾取一个曲线 
           ) 
           
           (vlax-curve-isclosed e) ;确定指定曲线是否闭合（即起点与端点是否重合） 
 
           (setq pts (xdrx_getsamplept e));;得到这个曲线的模拟顶点表 
 
           (setq ss (ssget "WP" pts '((0 . "CIRCLE"))));根据 圈围选定对像创建选择集 
           (setq d (getdist "\nRadius: ")) 
        
           (setq t0 (xdl-getutime)) 
      ) 
    (progn 
      (setq lst         (mapcar 
                   '(lambda (x / p) 
                      (setq p (xdrx_getpropertyvalue x "Center"));实体属性获取 (p 圆心) 
                      (setq cl (cons (xdrx_circle_make p d) cl));创建圆实体 
                      p 
                    ) 
                   (xdrx_pickset->ents ss);选择集中的实体表 
 
                 ) 
            lst1 (cons (ssname (xdrx_entity_copy e) 0) cl) ;实体拷贝 
 
            sm (XD::Entity->Pickset lst1) 
             
            ) 
 
        ;(mbb);交点打断 
       
      (setq 
 
            ;s1         (xdrx_curve_intersectbreak (XD::Entity->Pickset lst1) 0);将选择集中的曲线在所有交点处break 
 
            ;s1 (setq ss (ssget "WP" pts '((0 . "arc")))) 
        slst (mbb) 
        
        s1 (XD::Entity->Pickset slst) 
        
 
            s2         (xdrx_geom_searchregions s1 0);求给定选择集内的实体的连通区域所有边界 
 
            lst2 (xdrx_pickset->ents s2);选择集中的实体表 
 
            lst2 (vl-sort lst2 ;根据给定的比较函数来对表中的元素排序 
 
                          '(lambda (x1 x2) 
                             (>        (car (xdrx_getarea x1));求AutoCAD AcDbCurve(曲线)类的面积和周长(长度) 
 
                                (car (xdrx_getarea x2)) 
                             ) 
                           ) 
                 ) 
      ) 
      (xdrx_entity_delete (car lst2));删除当前空间或者块定义中的实体 
 
      (setq 
        nl (mapcar 
             '(lambda (x / p) 
                (if (setq 
                      p 
                       (cadr (assoc "Centroid" (xdrx_curve_info x)));获得AcDbCurve曲线实体(polyline,lwpolyline,arc,circle,ellipse,spline) 和AcDbRegion(REGION面域)实体的面积，周长，质心，惯性矩，回转半径，边界盒等信息。 
 
 
                    ) 
                  (list 
                    (length 
                      (vl-remove nil 
                                 (mapcar '(lambda (a) 
                                            (if        (< (distance p a) d) 
                                              t 
                                              nil 
                                            ) 
                                          ) 
                                         lst;->a 
                                 ) 
                      ) 
                    ) 
                    x 
                  ) 
                ) 
              ) 
             (cdr lst2) 
           ) 
      ) 
      (mapcar 
        '(lambda (x / ent) 
           (setq ent (xdrx_hatch_make (cadr x)));创建HATCH填充实体 
 
           (setq hl (cons ent hl)) 
           (if (zerop (car x));查验是否是0 
             (xdrx_entity_setcolor ent 15);设置一个实体的颜色 
 
             (xdrx_entity_setcolor ent (car x)) 
           ) 
         ) 
        (vl-remove nil nl) 
      ) 
      (apply 'xdrx_draworder->back hl);将参数实体和选择集的任意组合的实体顺序放到最后面 
 
    ) 
  ) 
  (princ (strcat "\n*****""耗时" 
                (rtos (- (xdl-getutime)t0)2 3) 
                 "秒" 
                 )) 
  (princ) 
) 
 
 
(defun XD::Entity->PickSet (entl / n ss x) 
  (setq ss (ssadd)) 
  (foreach n entl 
    (ssadd n ss) 
  ) 
  ss 
) 
 
  (defun xdl-getutime() 
    (* 86400 (getvar "tdusrtimer") 
       ) 
    ) 
 
 
;;交点打断主函数 
(defun MBB (/ elist ssg n t0 lst) 
    (setq lst '())   ;empty list 
  (VL-LOAD-COM) 
  (fy:clearcset) 
;;;  (setq t0 (xdl-getutime)) 
  (if ;(setq ssg (ssget '((0 . "line,arc,circle,ellipse")))) 
    (setq ssg sm)    
     (progn 
       (command "_.select" ssg "")       
    (vlax-for obj (vla-get-activeselectionset 
        (vla-get-activedocument (vlax-get-acad-object)) 
      ) 
      (setq elist (cons obj elist))  ; ssg->elist 
    ) 
    ) 
  ) 
 
 
    
  (setq lst (DoEntMake (InterSort (ssinter elist)))) 
  (princ) 
  lst 
) 
;;求交点集函数－nth 
;;经过测试，nth函数仅比assoc函数快一点点。 
;;故此函数也可取消i，j变量，直接使用assoc函数 
(defun ssinter (el / el1 obj1 obj2 ipts pts list1 outlst i j) 
  (setq outlst (mapcar 'list el) 
 i      -1   ;obj1位置指针 
 n      0   ;交点数计数器 
  ) 
  (while el 
    (setq obj1 (car el) 
   list1 (nth (setq i (1+ i)) outlst) ;obj1已有的交点列表 
   el (cdr el) 
   el1 el 
   j i   ;obj2位置指针 
    ) 
    (while el1 
      (setq obj2 (car el1) 
     el1  (cdr el1) 
     j  (1+ j) 
      ) 
      ;;取交点 
      (if (and (setq ipts (vla-intersectwith obj1 obj2 0)) 
        (setq ipts (vlax-variant-value ipts)) 
        (> (vlax-safearray-get-u-bound ipts 1) 0) 
   ) 
 (progn 
   (setq ipts (vlax-safearray->list ipts) 
  pts  '()  ;obj1,obj2交点临时列表变量 
   ) 
   (while (> (length ipts) 0) 
     (setq pts  (cons (list (car ipts) 
       (cadr ipts) 
       (caddr ipts) 
        ) 
        pts 
         ) 
    ipts (cdddr ipts) 
     ) 
   ) 
   (setq list1 (append list1 pts) ;存obj1交点表，循环结束后再更新 
  n     (+ n (length pts)) ;交点计数累加 
   ) 
   ;;obj2的交点列表立即更新 
   (setq 
     outlst (subst (append (nth j outlst) pts) 
     (nth j outlst) 
     outlst 
     ) 
   ) 
 ) 
      ) 
    ) 
    ;;当obj1存在交点，且非封闭曲线，添加两端点 
    (if (and (cdr list1) (not (vlax-curve-isClosed obj1))) 
      (setq list1 (append list1 
     (list (vlax-curve-getEndPoint obj1)) 
     (list (vlax-curve-getStartPoint obj1)) 
    ) 
      ) 
    ) 
    (setq outlst (subst list1 (nth i outlst) outlst)) ;更新obj1交点列表 
  ) 
  outlst 
) 
;;点集排序及删除重复点函数 
(defun InterSort (el / obj1 pts plst outlst) 
  (setq outlst '())   ;empty list 
  (foreach item el 
    (setq obj1 (car item) 
   pts  (cdr item) 
   plst '()   ;empty list 
    ) 
    (if pts    ;若无交点，则不修改该实体 
      (progn 
 ;;交点排序，列表为逆序 
 (setq 
   pts (vl-sort 
  pts 
  (function (lambda (p1 p2) 
       (< (vlax-curve-getParamAtPoint obj1 p1) 
          (vlax-curve-getParamAtPoint obj1 p2) 
       ) 
     ) 
  ) 
       ) 
 ) 
 ;;剔除重复点并将列表顺序转正 
 (foreach p pts 
   (if plst 
     (if (not (equal p (car plst) 0.00001)) 
       (setq plst (cons p plst)) 
     ) 
     (setq plst (cons p plst)) 
   ) 
 ) 
 ;;闭合曲线需再添加首个交点以使新实体完全封闭 
 (if (vlax-curve-isClosed obj1) 
   (setq plst (cons (last plst) plst)) 
 ) 
 (setq plst   (cons (vlax-vla-object->ename obj1) plst) 
       outlst (cons plst outlst) 
 ) 
      ) 
    ) 
  ) 
  outlst 
) 
;;调用entmake生成新实体 
(defun DoEntMake (el / obj objlst objname objcen objratio objaxis outlst) 
   (setq outlst '())   ;empty list 
  (foreach e el 
    (setq obj   (car e) 
   objlst  (entget obj) 
   objlst  (vl-remove (assoc -1 objlst) objlst) ;去除图元名 
   objlst  (vl-remove (assoc 330 objlst) objlst) ;去除id 
   objlst  (vl-remove (assoc 5 objlst) objlst) ;去除句柄 
   objname (cdr (assoc 0 objlst)) 
    ) 
    (cond 
      ((= objname "LINE") 
       (repeat (- (length e) 2) 
  (setq e (cdr e)) 
  (setq objlst (subst (cons 10 (car e)) (assoc 10 objlst) objlst)) 
  (setq objlst (subst (cons 11 (cadr e)) (assoc 11 objlst) objlst) 
          
        ) 
  (entmake objlst) 
         (setq outlsttem (entmakex objlst) 
               outlst (cons outlsttem outlst) 
               ) 
       ) 
       (entdel obj) 
      ) 
      ((= objname "CIRCLE") 
       (setq objcen (cdr (assoc 10 objlst))) 
       (setq objlst (subst (cons 0 "ARC") (assoc 0 objlst) objlst)) 
       (setq objlst (append objlst 
       (list (cons 100 "AcDbArc") 
      (cons 50 0.0) 
      (cons 51 0.0) 
       ) 
      ) 
       ) 
       (repeat (- (length e) 2) 
  (setq e (cdr e)) 
  (setq objlst (subst (cons 50 (angle objcen (cadr e))) 
        (assoc 50 objlst) 
        objlst 
        ) 
  ) 
  (setq objlst (subst (cons 51 (angle objcen (car e))) 
        (assoc 51 objlst) 
        objlst 
        ) 
 
  ) 
  (entmake objlst) 
         (setq outlsttem (entmakex objlst) 
               outlst (cons outlsttem outlst) 
               ) 
       ) 
       (entdel obj) 
      ) 
      ((= objname "ARC") 
       (setq objcen (cdr (assoc 10 objlst))) 
       (repeat (- (length e) 2) 
  (setq e (cdr e)) 
  (setq objlst (subst (cons 50 (angle objcen (cadr e))) 
        (assoc 50 objlst) 
        objlst 
        ) 
  ) 
  (setq objlst (subst (cons 51 (angle objcen (car e))) 
        (assoc 51 objlst) 
        objlst 
        ) 
 
  ) 
  (entmake objlst) 
         (setq outlsttem (entmakex objlst) 
               outlst (cons outlsttem outlst) 
               ) 
       ) 
       (entdel obj) 
      ) 
      ((= objname "ELLIPSE") 
       ;;椭圆圆心 
       (setq objcen (cdr (assoc 10 objlst))) 
       ;;相对于中心的长轴矢量 
       (setq objaxis (cdr (assoc 11 objlst))) 
       ;;短轴与长轴的比例 
       (setq objratio (cdr (assoc 40 objlst))) 
       (repeat (- (length e) 2) 
  (setq e (cdr e)) 
  (setq objlst (subst (cons 41 (pt->param (cadr e) objcen objaxis objratio)) 
        (assoc 41 objlst) 
        objlst 
        ) 
  ) 
  (setq objlst (subst (cons 42 (pt->param (car e) objcen objaxis objratio)) 
        (assoc 42 objlst) 
        objlst 
        ) 
 
  ) 
  (entmake objlst) 
         (setq outlsttem (entmakex objlst) 
               outlst (cons outlsttem outlst) 
               ) 
       ) 
       (entdel obj) 
      ) 
    ) 
  ) 
  outlst 
) 
;;计算耗时 
(defun xdl-getutime () 
  (* 86400 (getvar "tdusrtimer")) 
) 
;;求椭圆曲线参数 
(defun pt->param (pt cen axis ratio / ang param) 
  (setq ang (- (angle cen pt) (angle '(0. 0. 0.) axis))) 
  (cond ((= (cos ang) 0.0)  ;防止分母cos为零出错 
  (if (> (sin ang) 0.0) 
    (setq param (* 0.5 PI)) 
    (setq param (* 1.5 PI)) 
  ) 
 ) 
 ((= (sin ang) 0.0) 
  (if (> (cos ang) 0.0) 
    (setq param 0.0) 
    (setq param PI) 
  ) 
 ) 
 (T 
  (setq param (atan (/ (sin ang) (* (cos ang) ratio)))) 
  (if (< (cos ang) 0.0) 
    (setq param (+ pi param)) 
  ) 
 ) 
  ) 
  param 
) 
(princ) 
 
 
 
 
 
 
 
 
 
(defun fy:acapp        nil 
  (eval        (list 'defun 
              'fy:acapp 
              'nil 
              (vlax-get-acad-object) 
        ) 
  ) 
  (fy:acapp) 
) 
(defun fy:docs nil 
  (eval        (list 'defun 
              'fy:docs 
              'nil 
              (vla-get-documents (fy:acapp)) 
        ) 
  ) 
  (fy:docs) 
) 
(defun Fy:acDoc        nil 
  (eval        (list 'defun 
              'FY:acdoc 
              'nil 
              (vla-get-activedocument (vlax-get-acad-object)) 
        ) 
  ) 
  (fy:acdoc) 
) 
(defun fy:acsets nil 
  (eval        (list 'defun 
              'fy:acsets 
              'nil 
              (vla-get-Selectionsets (fy:acdoc)) 
        ) 
  ) 
  (fy:acsets) 
) 
;; From eachy 
(defun fy:Clearcset (/ cset) 
  (if (not (vl-catch-all-error-p 
             (setq cset 
                    (vl-catch-all-apply 
                      'vla-item 
                      (list 
                        (fy:acsets) 
                        "CURRENT" 
                      ) 
                    ) 
             ) 
           ) 
      ) 
    (vla-delete cset) 
  ) 
  (princ) 
) 
(defun fy:cset () 
  (vla-get-activeselectionset (fy:acdoc)) 
) 
(defun fy:cset->objs (/ ol) 
  (vlax-for obj        (fy:cset) 
    (setq ol (cons obj ol)) 
  ) 
  (reverse ol) 
)

多余的代码就不删了，都比我水平高，呵呵

Free-Lancer · 发表于 2014-8-29 16:31:46

bbswen 发表于 2014-8-29 16:11
请大大门指点一下，精简一下，
再帮我扩展下，
大圆外不统计，

外侧填充在填充时就可以过滤掉
统计面积就简单了

(defun c:tt (/ lst)
(fy:begin)
(if (ssget '((0 . "Hatch")))
(progn
(setq lst (mapcar '(lambda (x)
(list (vlax-get x 'Color)
(vlax-get x 'Area)
)
)
(fy:cset->objs)
)
lst (xd::list:groupbyindex lst 0)
lst (mapcar '(lambda (x)
(list (car x) (apply '+ (cdr x)))
)
lst
)
)
(princ lst)
)
)
(fy:end)
(princ)
)

eachy · 发表于 2014-8-30 09:42:17

API 更新后的效果

eachy · 发表于 2014-8-30 11:02:57

API 及函数库发布新版后再做为 "插件发布"

(defun xd::entity->pickset (el / ss)
(setq ss (ssadd))
(foreach x el (ssadd x ss))
ss
)
(defun c:tt1 (/ e pts ss d lst
s1 s2 lst1 cl nl lst2
hl _carea _Pnts:IsInside _Pnt:OneOfIn
p _Solid:Make box
)
(defun _Solid:Make (p lst / p1 p2 p3)
(setq p1 (polar p 0. 2000)
p2 (polar p (- _pi2) 800)
p3 (polar p2 0. 2000)
)
(if (zerop (car lst))
(xdrx_polyline_make t p p1 p3 p2)
(xdrx_entity_setcolor
(xdrx_solid_make p p2 p1 p3)
(if (>= (car lst) 7)
(1+ (car lst))
(car lst)
)
)
)
(xdrx_text_make
(mapcar '+ p2 '(2200 200 0))
(strcat "重合 "
(itoa (car lst))
" 层, 面积 "
(rtos (cadr lst) 2 2)
)
250.
0.
)
)
(defun _Pnts:IsInside (e pts)
(apply 'and
(mapcar '(lambda (p)
(or (xdrx_point_isinside p e);_和图形显示有关，放大
(xdrx_point_ison p e)
)
)
pts
)
)
)
(defun _Pnt:OneOfIn (e / p1 p2)
(setq p1 (xdrx_curve_getpointatparam e 1.2)
p2 (xdrx_curve_getpointatparam e 0.8)
p (xdrx_line_midp p1 p2)
)
)
(if (and (setq e (car (xdrx_entsel
"\n拾取范围线 "
'((0 . "*Polyline,CIRCLE,ELLIPSE,SPLINE"))
)
)
)
(vlax-curve-isclosed e)
(progn
(setq box (xdrx_entity_box e))
(xdrx_document_zoomwindow (car box) (caddr box))
t
)
(setq pts (xdrx_getsamplept e))
(setq ss (ssget "WP" pts '((0 . "CIRCLE"))))
(setq d (getdist "\n半径: "))
)
(progn
(setq lst (mapcar
'(lambda (x / p)
(setq p (xdrx_getpropertyvalue x "Center"))
(setq cl (cons (xdrx_circle_make p d) cl))
p
)
(xdrx_pickset->ents ss)
)
lst1 (cons (ssname (xdrx_entity_copy e) 0) cl)
s1 (xdrx_curve_intersectbreak (XD::Entity->Pickset lst1) 0)
s2 (xdrx_geom_searchregions s1 0)
lst2 (xdrx_pickset->ents s2)
lst2 (vl-sort lst2
'(lambda (x1 x2)
(> (car (xdrx_getarea x1))
(car (xdrx_getarea x2))
)
)
)
_carea (* pi d d)
)
(xdrx_entity_delete (car lst2))
(setq lst2
(mapcar
'(lambda (x / p)
(if (or (_Pnts:Isinside
e
(xdrx_entity_getstretchpoint x)
)
(> (car (xdrx_getarea x)) _carea)
)
(progn
(setq p (_Pnt:OneOfIn x))
(list (length (vl-remove-if
'(lambda (a) (> (distance a p) d))
lst
)
)
x
)
)
(progn
(xdrx_entity_delete x)
nil
)
)
)
(cdr lst2)
)
lst2 (vl-remove nil lst2)
nl (mapcar
'(lambda (x)
(list
(car x)
(apply
'+
(mapcar 'car (mapcar 'xdrx_getarea (cdr x)))
)
)
)
(xd::list:groupbyindex lst2 0)
)
)
(mapcar '(lambda (x / ent)
(if (not (zerop (car x)))
(progn (setq ent (xdrx_hatch_make (cadr x)))
(setq hl (cons ent hl))
(xdrx_entity_setcolor
ent
(if (>= (car x) 7)
(1+ (car x))
(car x)
)
)
)
)
)
lst2
)
(apply 'xdrx_draworder->back hl)
(xdrx_document_zoomPrevious)
(if (setq p (getpoint "\nOutput Point: "))
(mapcar '(lambda (x)
(_Solid:Make p x)
(setq p (mapcar '+ '(0 -1200 0) p))
)
(vl-sort nl '(lambda (l1 l2) (< (car l1) (car l2))))
)
)
)
)
(princ)
)

(defun xd::entity->pickset (el / ss) 
  (setq ss (ssadd)) 
  (foreach x el (ssadd x ss)) 
  ss 
) 
(defun c:tt1 (/               e        pts         ss          d           lst 
              s1       s2        lst1         cl          nl           lst2 
              hl       _carea        _Pnts:IsInside          _Pnt:OneOfIn 
              p               _Solid:Make         box 
             ) 
  (defun _Solid:Make (p lst / p1 p2 p3) 
    (setq p1 (polar p 0. 2000) 
          p2 (polar p (- _pi2) 800) 
          p3 (polar p2 0. 2000) 
    ) 
    (if        (zerop (car lst)) 
      (xdrx_polyline_make t p p1 p3 p2) 
      (xdrx_entity_setcolor 
        (xdrx_solid_make p p2 p1 p3) 
        (if (>= (car lst) 7) 
          (1+ (car lst)) 
          (car lst) 
        ) 
      ) 
    ) 
    (xdrx_text_make 
      (mapcar '+ p2 '(2200 200 0)) 
      (strcat "重合 " 
              (itoa (car lst)) 
              " 层, 面积 " 
              (rtos (cadr lst) 2 2) 
      ) 
      250. 
      0. 
    ) 
  ) 
   
  (defun _Pnts:IsInside        (e pts) 
    (apply 'and 
           (mapcar '(lambda (p) 
                      (or (xdrx_point_isinside p e);_和图形显示有关，放大 
                          (xdrx_point_ison p e) 
                      ) 
                    ) 
                   pts 
           ) 
    ) 
  ) 
  (defun _Pnt:OneOfIn (e / p1 p2) 
    (setq p1 (xdrx_curve_getpointatparam e 1.2) 
          p2 (xdrx_curve_getpointatparam e 0.8) 
          p  (xdrx_line_midp p1 p2) 
    ) 
  ) 
  (if (and (setq e (car        (xdrx_entsel 
                          "\n拾取范围线 " 
                          '((0 . "*Polyline,CIRCLE,ELLIPSE,SPLINE")) 
                        ) 
                   ) 
           ) 
           (vlax-curve-isclosed e) 
           (progn 
             (setq box (xdrx_entity_box e)) 
             (xdrx_document_zoomwindow (car box) (caddr box)) 
             t 
           ) 
           (setq pts (xdrx_getsamplept e)) 
           (setq ss (ssget "WP" pts '((0 . "CIRCLE")))) 
           (setq d (getdist "\n半径: ")) 
      ) 
    (progn 
      (setq lst           (mapcar 
                     '(lambda (x / p) 
                        (setq p (xdrx_getpropertyvalue x "Center")) 
                        (setq cl (cons (xdrx_circle_make p d) cl)) 
                        p 
                      ) 
                     (xdrx_pickset->ents ss) 
                   ) 
            lst1   (cons (ssname (xdrx_entity_copy e) 0) cl) 
            s1           (xdrx_curve_intersectbreak (XD::Entity->Pickset lst1) 0) 
            s2           (xdrx_geom_searchregions s1 0) 
            lst2   (xdrx_pickset->ents s2) 
            lst2   (vl-sort lst2 
                            '(lambda (x1 x2) 
                               (> (car (xdrx_getarea x1)) 
                                  (car (xdrx_getarea x2)) 
                               ) 
                             ) 
                   ) 
            _carea (* pi d d) 
      ) 
      (xdrx_entity_delete (car lst2)) 
      (setq lst2 
                 (mapcar 
                   '(lambda (x / p) 
                      (if (or (_Pnts:Isinside 
                                e 
                                (xdrx_entity_getstretchpoint x) 
                              ) 
                              (> (car (xdrx_getarea x)) _carea) 
                          ) 
                        (progn 
                          (setq p (_Pnt:OneOfIn x)) 
                          (list        (length        (vl-remove-if 
                                          '(lambda (a) (> (distance a p) d)) 
                                          lst 
                                        ) 
                                ) 
                                x 
                          ) 
                        ) 
                        (progn 
                          (xdrx_entity_delete x) 
                          nil 
                        ) 
                      ) 
                    ) 
                   (cdr lst2) 
                 ) 
            lst2 (vl-remove nil lst2) 
            nl         (mapcar 
                   '(lambda (x) 
                      (list 
                        (car x) 
                        (apply 
                          '+ 
                          (mapcar 'car (mapcar 'xdrx_getarea (cdr x))) 
                        ) 
                      ) 
                    ) 
                   (xd::list:groupbyindex lst2 0) 
                 ) 
      ) 
      (mapcar '(lambda (x / ent) 
                 (if (not (zerop (car x))) 
                   (progn (setq ent (xdrx_hatch_make (cadr x))) 
                          (setq hl (cons ent hl)) 
                          (xdrx_entity_setcolor 
                            ent 
                            (if        (>= (car x) 7) 
                              (1+ (car x)) 
                              (car x) 
                            ) 
                          ) 
                   ) 
                 ) 
               ) 
              lst2 
      ) 
      (apply 'xdrx_draworder->back hl) 
      (xdrx_document_zoomPrevious) 
      (if (setq p (getpoint "\nOutput Point: ")) 
        (mapcar        '(lambda (x) 
                   (_Solid:Make p x) 
                   (setq p (mapcar '+ '(0 -1200 0) p)) 
                 ) 
                (vl-sort nl '(lambda (l1 l2) (< (car l1) (car l2)))) 
        ) 
      ) 
    ) 
  ) 
  (princ) 
)

newer · 发表于 2014-8-30 11:36:52

eachy 发表于 2014-8-30 11:02
API 及函数库发布新版后再做为 "插件发布"

这个多长时间啊？

eachy · 发表于 2014-8-30 11:44:29

newer 发表于 2014-8-30 11:36
这个多长时间啊？

xdrx_curve_intersectwith 很快了，瞬间
后面延迟可能是 Hatch_make 加显示稍停顿

bbswen · 发表于 2014-8-30 16:12:55

本帖最后由 bbswen 于 2014-8-30 16:18 编辑

XDRX_DOCUMENT_ZOOMWINDOW
这个命令也是新增的吗？这个是新的API中的命令吧，

bbswen · 发表于 2014-8-30 16:35:51

st2 (vl-remove nil lst2)
 nl (mapcar
 '(lambda (x)
 (list
 (car x)
 (apply
 '+
 (mapcar 'car (mapcar 'xdrx_getarea (cdr x)))
 )
 )
 )
 (xd::list:groupbyindex lst2 0)；；
；在执行到这句后，lst2最后一个值后，可能是存在溢出。

；((0 <图元名: 7eb5f0e0>) (1 <图元名: 7eb5f0d0>) (1 <图元名: 7eb5f0d8>))

；上句执行到最后一个值，提示：

;; 错误: 参数类型错误: numberp: (1.0 <图元名: 7eb5f0d8> <图元名: 7eb5f0d0>)

;;API8-10版本

 )
 )
 (mapcar '(lambda (x / ent)
 (if (not (zerop (car x)))
 (progn (setq ent (xdrx_hatch_make (cadr x)))

newer · 发表于 2014-8-30 16:36:44

bbswen 发表于 2014-8-30 16:12
XDRX_DOCUMENT_ZOOMWINDOW
这个命令也是新增的吗？这个是新的API中的命令吧，

下载最新的0830 API。

eachy · 发表于 2014-8-30 16:43:52

bbswen 发表于 2014-8-30 16:35
st2 (vl-remove nil lst2)
nl (mapcar
'(lambda (x)

下载最新的 lisp 函数库，更新了 XD::List:GroupByIndex ，这个函数源码在 "函数发布“

bbswen · 发表于 2014-8-31 19:50:48

感谢信“eachy”的更新，代码简洁，功能明了，不知道“eachy”测试的和发布是否一个版本，
先说下我的电脑城配置
winxp sp3 cad2007
加载开发接口，如下，
*** ≡ AutoCAD 应用程序开发接口XDRX_API For AutoCAD Build 2014.8.30 ≡ ***

黄
AutoCAD Express Tools Copyright ?2002-2004 Autodesk, Inc.

晓东通用LISP函数库Build 2014.08.30加载完毕...Couldn't find OpenDCL.17.arx.

看下“eachy”的代码，在我电脑上的测试图，

说下问题：
1，一个内圆时，外部的没有去掉，统计时也没有去了，
2，很多时，偶尔圆外的没有去掉，，
3，内圆很多位置，没有了，变空白了，

csharp · 发表于 2014-8-31 20:04:01

本帖最后由 csharp 于 2014-8-31 20:55 编辑

这个里面用到的点在曲线内，应该有转 Ge ，所以和曲线显示大小有关，可以将 xdrx_doucument_zoomwindow放到生成 searchregions 之后， (apply 'xdrx_document_zoomwindow (xdrx_entity_box s2))

经测试，问题应该出在xdrx_point_isinside上

账号		自动登录	找回密码
密码			立即注册

[求助] 统计圆的交集次数及填充

点评

点评

点评

点评

点评

点评

点评