对于曲线、点、REGIONS、3DSOLID的OVERKILL实现代码

marting · 发表于 2017-7-18 19:16:06

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

1、对于一般的2D/3D曲线的OVERKILL:

(defun c:OVERKILL-MR ( / adoc *error* nolst seg fuzz ss i k sss curve m n ent entl pt ptlst ii zz kk iii curvetst ptt pttlst curves )
(vl-load-com)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(defun *error* ( msg )
(vla-endundomark adoc)
(if msg (prompt msg))
(princ)
)
(defun nolst ( st en / lst )
(repeat (- en st)
(setq st (1+ st))
(setq lst (cons st lst))
)
(reverse lst)
)
(vla-startundomark adoc)
(initget 6)
(setq seg (getint "\nNumber of segmentation of testing points along curve [smaller-less accurate but faster/larger-more accurate but slower] <100> : "))
(if (null seg) (setq seg 100))
(initget 6)
(setq fuzz (getreal "\nFuzz factor of distance between testing points and closest points on other testing curve <1e-4> : "))
(if (null fuzz) (setq fuzz 1e-4))
(if (ssget "_A" (list (cons 410 (if (= 1 (getvar 'cvport)) (getvar 'ctab) "Model")))) (command "_.-overkill" "all" "" "_o" fuzz "_i" "_a" "_p" "_y" ""))
(prompt "\nSelect curves for curvekill operation")
(setq ss (ssget "_:L" '((0 . "*POLYLINE,SPLINE,HELIX,LINE,ARC,CIRCLE,ELLIPSE"))))
(setq i -1)
(setq k 0)
(setq kk 0)
(setq sss (ssadd))
(if ss
(progn
(while (setq curve (ssname ss (setq i (1+ i))))
(setq m -1.0)
(repeat (+ seg 1)
(setq pt (vlax-curve-getpointatparam curve (+ (vlax-curve-getstartparam curve) (* (setq m (1+ m)) (/ (- (vlax-curve-getendparam curve) (vlax-curve-getstartparam curve)) (float seg))))))
(if (not (eq m seg))
(setq ptlst (cons pt ptlst))
(setq ptlst (cons (vlax-curve-getendpoint curve) ptlst))
)
)
(setq ptlst (vl-remove nil ptlst))
(setq pt (car ptlst))
(if (vl-every '(lambda ( x ) (equal x pt fuzz)) ptlst)
(progn
(entdel curve)
(setq k (1+ k))
)
(ssadd curve sss)
)
(setq ptlst nil)
)
(setq ii -1)
(setq zz -1)
(repeat (setq n (sslength sss))
(setq ent (ssname sss (setq n (1- n))))
(setq entl (cons ent entl))
)
(setq entl (vl-sort entl '(lambda ( a b ) (> (vlax-curve-getdistatparam a (vlax-curve-getendparam a)) (vlax-curve-getdistatparam b (vlax-curve-getendparam b))))))
(setq sss (ssadd))
(foreach ent entl
(ssadd ent sss)
)
(if (/= (sslength sss) 0)
(progn
(while (setq curve (ssname sss (setq ii (1+ ii))))
(foreach iii (vl-remove ii (if (null (nolst zz (if sss (1- (sslength sss)) zz))) (list ii) (nolst zz (if sss (1- (sslength sss)) zz))))
(setq curvetst (ssname sss iii))
(setq m -1.0)
(repeat (+ seg 1)
(setq pt (vlax-curve-getpointatparam curvetst (+ (vlax-curve-getstartparam curvetst) (* (setq m (1+ m)) (/ (- (vlax-curve-getendparam curvetst) (vlax-curve-getstartparam curvetst)) (float seg))))))
(if (not (eq m seg))
(setq pttlst (cons pt pttlst))
(setq pttlst (cons (vlax-curve-getendpoint curve) pttlst))
)
)
(foreach ptt pttlst
(setq ptt (vlax-curve-getclosestpointto curve ptt))
(setq ptlst (cons ptt ptlst))
)
(setq ptlst (reverse ptlst))
(if (and
(vl-every '(lambda ( a b ) (equal a b fuzz)) ptlst pttlst)
(or
(if (setq pt (vlax-curve-getpointatparam curvetst (vlax-curve-getparamatpoint curvetst (vlax-curve-getclosestpointto curvetst (vlax-curve-getpointatparam curve (+ (vlax-curve-getstartparam curve) 1e-10)))))) ;; pt is either startpoint of curvetst or some point on curvetst
(if (not (equal (distance pt (vlax-curve-getstartpoint curve)) 0.0 fuzz))
;; startpoint of curve is not equal to startpoint of curvetst
(if (setq pt (vlax-curve-getpointatparam curve (vlax-curve-getparamatpoint curve (vlax-curve-getclosestpointto curve (vlax-curve-getstartpoint curvetst))))) ;; pt is either startpoint of curve or some point on curve
(equal (distance pt (vlax-curve-getstartpoint curvetst)) 0.0 fuzz) ;; startpoint of curvetst "closely belongs" to curve and is not equal to startpoint of curve as it belongs to then statement of if function that checked that startpoint of curve is not equal to startpoint of curvetst
)
(or
(equal (distance (vlax-curve-getstartpoint curve) (vlax-curve-getstartpoint curvetst)) 0.0 fuzz) ;; startpoint of curve is equal to startpoint of curvetst
(equal (distance (vlax-curve-getstartpoint curve) (vlax-curve-getendpoint curvetst)) 0.0 fuzz) ;; startpoint of curve is equal to endpoint of curvetst
(equal (distance (vlax-curve-getendpoint curve) (vlax-curve-getstartpoint curvetst)) 0.0 fuzz) ;; endpoint of curve is equal to startpoint of curvetst
(equal (distance (vlax-curve-getendpoint curve) (vlax-curve-getendpoint curvetst)) 0.0 fuzz) ;; endpoint of curve is equal to endpoint of curvetst
) ;; or checks coincidence of start/end points of curve and curvetst and for cases of reversed curves
)
)
(if (setq pt (vlax-curve-getpointatparam curvetst (vlax-curve-getparamatpoint curvetst (vlax-curve-getclosestpointto curvetst (vlax-curve-getpointatparam curve (- (vlax-curve-getendparam curve) 1e-10)))))) ;; pt is either endpoint of curvetst or some point on curvetst
(if (not (equal (distance pt (vlax-curve-getendpoint curvetst)) 0.0 fuzz))
;; endpoint of curve is not equal to endpoint of curvetst
(if (setq pt (vlax-curve-getpointatparam curve (vlax-curve-getparamatpoint curve (vlax-curve-getclosestpointto curve (vlax-curve-getendpoint curvetst))))) ;; pt is either endpoint of curve or some point on curve
(equal (distance pt (vlax-curve-getstartpoint curvetst)) 0.0 fuzz) ;; endpoint of curvetst "closely belongs" to curve and is not equal to endpoint of curve as it belongs to then statement of if function that checked that endpoint of curve is not equal to endpoint of curvetst
)
(or
(equal (distance (vlax-curve-getstartpoint curve) (vlax-curve-getstartpoint curvetst)) 0.0 fuzz) ;; startpoint of curve is equal to startpoint of curvetst
(equal (distance (vlax-curve-getstartpoint curve) (vlax-curve-getendpoint curvetst)) 0.0 fuzz) ;; startpoint of curve is equal to endpoint of curvetst
(equal (distance (vlax-curve-getendpoint curve) (vlax-curve-getstartpoint curvetst)) 0.0 fuzz) ;; endpoint of curve is equal to startpoint of curvetst
(equal (distance (vlax-curve-getendpoint curve) (vlax-curve-getendpoint curvetst)) 0.0 fuzz) ;; endpoint of curve is equal to endpoint of curvetst
) ;; or checks coincidence of start/end points of curve and curvetst and for cases of reversed curves
)
)
) ;; curvetst is "inside" or equal to curve
)
(if (not (vl-position curve curves))
(setq curves (cons curvetst curves))
)
)
(setq ptlst nil pttlst nil)
)
)
(foreach curve curves
(setq kk (1+ kk))
(entdel curve)
)
)
)
)
)
(prompt "\nTotal : ")(princ kk)(prompt " duplicate-curves erased")
(prompt "\nTotal : ")(princ k)(prompt " zero-curves erased")
; (command "_.-purge" "_b" "" "_n")
; (command "_.-purge" "_de" "" "_n")
; (command "_.-purge" "_d" "" "_n")
; (command "_.-purge" "_g" "" "_n")
; (command "_.-purge" "_la" "" "_n")
; (command "_.-purge" "_lt" "" "_n")
; (command "_.-purge" "_ma" "" "_n")
; (command "_.-purge" "_mu" "" "_n")
; (command "_.-purge" "_p" "" "_n")
; (command "_.-purge" "_sh" "" "_n")
; (command "_.-purge" "_st" "" "_n")
; (command "_.-purge" "_m" "" "_n")
; (command "_.-purge" "_se" "" "_n")
; (command "_.-purge" "_t" "" "_n")
; (command "_.-purge" "_v" "" "_n")
; (command "_.-purge" "_r" "" "_n")
(command "_.-purge" "_z")
(command "_.-purge" "_e")
(*error* nil)
)

(defun c:OVERKILL-MR ( / adoc *error* nolst seg fuzz ss i k sss curve m n ent entl pt ptlst ii zz kk iii curvetst ptt pttlst curves ) 
 
  (vl-load-com) 
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))) 
 
  (defun *error* ( msg ) 
    (vla-endundomark adoc) 
    (if msg (prompt msg)) 
    (princ) 
  ) 
 
  (defun nolst ( st en / lst ) 
    (repeat (- en st) 
      (setq st (1+ st)) 
      (setq lst (cons st lst)) 
    ) 
    (reverse lst) 
  ) 
 
  (vla-startundomark adoc) 
  (initget 6) 
  (setq seg (getint "\nNumber of segmentation of testing points along curve [smaller-less accurate but faster/larger-more accurate but slower] <100> : ")) 
  (if (null seg) (setq seg 100)) 
  (initget 6) 
  (setq fuzz (getreal "\nFuzz factor of distance between testing points and closest points on other testing curve <1e-4> : ")) 
  (if (null fuzz) (setq fuzz 1e-4)) 
  (if (ssget "_A" (list (cons 410 (if (= 1 (getvar 'cvport)) (getvar 'ctab) "Model")))) (command "_.-overkill" "all" "" "_o" fuzz "_i" "_a" "_p" "_y" "")) 
  (prompt "\nSelect curves for curvekill operation") 
  (setq ss (ssget "_:L" '((0 . "*POLYLINE,SPLINE,HELIX,LINE,ARC,CIRCLE,ELLIPSE")))) 
  (setq i -1) 
  (setq k 0) 
  (setq kk 0) 
  (setq sss (ssadd)) 
  (if ss 
    (progn 
      (while (setq curve (ssname ss (setq i (1+ i)))) 
        (setq m -1.0) 
        (repeat (+ seg 1) 
          (setq pt (vlax-curve-getpointatparam curve (+ (vlax-curve-getstartparam curve) (* (setq m (1+ m)) (/ (- (vlax-curve-getendparam curve) (vlax-curve-getstartparam curve)) (float seg)))))) 
          (if (not (eq m seg)) 
            (setq ptlst (cons pt ptlst)) 
            (setq ptlst (cons (vlax-curve-getendpoint curve) ptlst)) 
          ) 
        ) 
        (setq ptlst (vl-remove nil ptlst)) 
        (setq pt (car ptlst)) 
        (if (vl-every '(lambda ( x ) (equal x pt fuzz)) ptlst) 
          (progn 
            (entdel curve) 
            (setq k (1+ k)) 
          ) 
          (ssadd curve sss) 
        ) 
        (setq ptlst nil) 
      ) 
      (setq ii -1) 
      (setq zz -1) 
      (repeat (setq n (sslength sss)) 
        (setq ent (ssname sss (setq n (1- n)))) 
        (setq entl (cons ent entl)) 
      ) 
      (setq entl (vl-sort entl '(lambda ( a b ) (> (vlax-curve-getdistatparam a (vlax-curve-getendparam a)) (vlax-curve-getdistatparam b (vlax-curve-getendparam b)))))) 
      (setq sss (ssadd)) 
      (foreach ent entl 
        (ssadd ent sss) 
      ) 
      (if (/= (sslength sss) 0) 
        (progn 
          (while (setq curve (ssname sss (setq ii (1+ ii)))) 
            (foreach iii (vl-remove ii (if (null (nolst zz (if sss (1- (sslength sss)) zz))) (list ii) (nolst zz (if sss (1- (sslength sss)) zz)))) 
              (setq curvetst (ssname sss iii)) 
              (setq m -1.0) 
              (repeat (+ seg 1) 
                (setq pt (vlax-curve-getpointatparam curvetst (+ (vlax-curve-getstartparam curvetst) (* (setq m (1+ m)) (/ (- (vlax-curve-getendparam curvetst) (vlax-curve-getstartparam curvetst)) (float seg)))))) 
                (if (not (eq m seg)) 
                  (setq pttlst (cons pt pttlst)) 
                  (setq pttlst (cons (vlax-curve-getendpoint curve) pttlst)) 
                ) 
              ) 
              (foreach ptt pttlst 
                (setq ptt (vlax-curve-getclosestpointto curve ptt)) 
                (setq ptlst (cons ptt ptlst)) 
              ) 
              (setq ptlst (reverse ptlst)) 
              (if (and 
                    (vl-every '(lambda ( a b ) (equal a b fuzz)) ptlst pttlst) 
                    (or 
                      (if (setq pt (vlax-curve-getpointatparam curvetst (vlax-curve-getparamatpoint curvetst (vlax-curve-getclosestpointto curvetst (vlax-curve-getpointatparam curve (+ (vlax-curve-getstartparam curve) 1e-10)))))) ;; pt is either startpoint of curvetst or some point on curvetst 
                        (if (not (equal (distance pt (vlax-curve-getstartpoint curve)) 0.0 fuzz)) 
                          ;; startpoint of curve is not equal to startpoint of curvetst 
                          (if (setq pt (vlax-curve-getpointatparam curve (vlax-curve-getparamatpoint curve (vlax-curve-getclosestpointto curve (vlax-curve-getstartpoint curvetst))))) ;; pt is either startpoint of curve or some point on curve 
                            (equal (distance pt (vlax-curve-getstartpoint curvetst)) 0.0 fuzz) ;; startpoint of curvetst "closely belongs" to curve and is not equal to startpoint of curve as it belongs to then statement of if function that checked that startpoint of curve is not equal to startpoint of curvetst 
                          ) 
                          (or 
                            (equal (distance (vlax-curve-getstartpoint curve) (vlax-curve-getstartpoint curvetst)) 0.0 fuzz) ;; startpoint of curve is equal to startpoint of curvetst 
                            (equal (distance (vlax-curve-getstartpoint curve) (vlax-curve-getendpoint curvetst)) 0.0 fuzz) ;; startpoint of curve is equal to endpoint of curvetst 
                            (equal (distance (vlax-curve-getendpoint curve) (vlax-curve-getstartpoint curvetst)) 0.0 fuzz) ;; endpoint of curve is equal to startpoint of curvetst 
                            (equal (distance (vlax-curve-getendpoint curve) (vlax-curve-getendpoint curvetst)) 0.0 fuzz) ;; endpoint of curve is equal to endpoint of curvetst 
                          ) ;; or checks coincidence of start/end points of curve and curvetst and for cases of reversed curves 
                        ) 
                      ) 
                      (if (setq pt (vlax-curve-getpointatparam curvetst (vlax-curve-getparamatpoint curvetst (vlax-curve-getclosestpointto curvetst (vlax-curve-getpointatparam curve (- (vlax-curve-getendparam curve) 1e-10)))))) ;; pt is either endpoint of curvetst or some point on curvetst 
                        (if (not (equal (distance pt (vlax-curve-getendpoint curvetst)) 0.0 fuzz)) 
                          ;; endpoint of curve is not equal to endpoint of curvetst 
                          (if (setq pt (vlax-curve-getpointatparam curve (vlax-curve-getparamatpoint curve (vlax-curve-getclosestpointto curve (vlax-curve-getendpoint curvetst))))) ;; pt is either endpoint of curve or some point on curve 
                            (equal (distance pt (vlax-curve-getstartpoint curvetst)) 0.0 fuzz) ;; endpoint of curvetst "closely belongs" to curve and is not equal to endpoint of curve as it belongs to then statement of if function that checked that endpoint of curve is not equal to endpoint of curvetst 
                          ) 
                          (or 
                            (equal (distance (vlax-curve-getstartpoint curve) (vlax-curve-getstartpoint curvetst)) 0.0 fuzz) ;; startpoint of curve is equal to startpoint of curvetst 
                            (equal (distance (vlax-curve-getstartpoint curve) (vlax-curve-getendpoint curvetst)) 0.0 fuzz) ;; startpoint of curve is equal to endpoint of curvetst 
                            (equal (distance (vlax-curve-getendpoint curve) (vlax-curve-getstartpoint curvetst)) 0.0 fuzz) ;; endpoint of curve is equal to startpoint of curvetst 
                            (equal (distance (vlax-curve-getendpoint curve) (vlax-curve-getendpoint curvetst)) 0.0 fuzz) ;; endpoint of curve is equal to endpoint of curvetst 
                          ) ;; or checks coincidence of start/end points of curve and curvetst and for cases of reversed curves 
                        ) 
                      ) 
                    ) ;; curvetst is "inside" or equal to curve 
                  ) 
                (if (not (vl-position curve curves)) 
                  (setq curves (cons curvetst curves)) 
                ) 
              ) 
              (setq ptlst nil pttlst nil) 
            ) 
          ) 
          (foreach curve curves 
            (setq kk (1+ kk)) 
            (entdel curve) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (prompt "\nTotal : ")(princ kk)(prompt " duplicate-curves erased") 
  (prompt "\nTotal : ")(princ k)(prompt " zero-curves erased") 
;  (command "_.-purge" "_b" "" "_n") 
;  (command "_.-purge" "_de" "" "_n") 
;  (command "_.-purge" "_d" "" "_n") 
;  (command "_.-purge" "_g" "" "_n") 
;  (command "_.-purge" "_la" "" "_n") 
;  (command "_.-purge" "_lt" "" "_n") 
;  (command "_.-purge" "_ma" "" "_n") 
;  (command "_.-purge" "_mu" "" "_n") 
;  (command "_.-purge" "_p" "" "_n") 
;  (command "_.-purge" "_sh" "" "_n") 
;  (command "_.-purge" "_st" "" "_n") 
;  (command "_.-purge" "_m" "" "_n") 
;  (command "_.-purge" "_se" "" "_n") 
;  (command "_.-purge" "_t" "" "_n") 
;  (command "_.-purge" "_v" "" "_n") 
;  (command "_.-purge" "_r" "" "_n") 
  (command "_.-purge" "_z") 
  (command "_.-purge" "_e") 
  (*error* nil) 
)

2、对于2D/3D 点的OVERKILL:

(defun c:overkill-pts ( / ss i ent entptlst k subentptlst )
(setq ss (ssget "_:L" '((0 . "POINT"))))
(repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i))))
(setq entptlst (cons (list ent (cdr (assoc 10 (entget ent)))) entptlst))
)
(setq k 0)
(foreach entpt entptlst
(setq subentptlst (vl-remove nil (mapcar '(lambda ( x ) (if (equal (cadr entpt) (cadr x) 1e-6) x)) entptlst)))
(setq subentptlst (vl-remove entpt subentptlst))
(foreach subentpt subentptlst
(if (entget (car subentpt))
(progn
(setq k (1+ k))
(entdel (car subentpt))
)
)
)
(if (not (entget (car entpt)))
(progn
(entdel (car entpt))
(setq k (1- k))
)
)
)
(prompt "\nTotal : ") (princ k) (prompt " duplicate point entities deleted...")
(princ)
)

(defun c:overkill-pts ( / ss i ent entptlst k subentptlst ) 
  (setq ss (ssget "_:L" '((0 . "POINT")))) 
  (repeat (setq i (sslength ss)) 
    (setq ent (ssname ss (setq i (1- i)))) 
    (setq entptlst (cons (list ent (cdr (assoc 10 (entget ent)))) entptlst)) 
  ) 
  (setq k 0) 
  (foreach entpt entptlst 
    (setq subentptlst (vl-remove nil (mapcar '(lambda ( x ) (if (equal (cadr entpt) (cadr x) 1e-6) x)) entptlst))) 
    (setq subentptlst (vl-remove entpt subentptlst)) 
    (foreach subentpt subentptlst 
      (if (entget (car subentpt)) 
        (progn 
          (setq k (1+ k)) 
          (entdel (car subentpt)) 
        ) 
      ) 
    ) 
    (if (not (entget (car entpt))) 
      (progn 
        (entdel (car entpt)) 
        (setq k (1- k)) 
      ) 
    ) 
  ) 
  (prompt "\nTotal : ") (princ k) (prompt " duplicate point entities deleted...") 
  (princ) 
)

3、对于 REGIONS的OVERKILL

(defun c:overkill-regs ( / *error* nolst v^v unit *adoc* ucs ucsf fuzzar fuzzce ss i ii zz kk sss reg ar n x y p ce regtst art cet regs )
(vl-load-com)
(defun *error* ( msg )
(while (not (eq (getvar 'worlducs) 1))
(command "_.UCS" "_P")
)
(if ucsf (command "_.UCS" "_P"))
(vla-endundomark *adoc*)
(if msg (prompt msg))
(princ)
)
(defun nolst ( st en / lst )
(repeat (- en st)
(setq st (1+ st))
(setq lst (cons st lst))
)
(reverse lst)
)
(defun v^v ( u v )
(mapcar '(lambda ( s1 s2 a b ) (+ ((eval s1) (* (nth a u) (nth b v))) ((eval s2) (* (nth a v) (nth b u))))) '(+ - +) '(- + -) '(1 0 0) '(2 2 1))
)
(defun unit ( v )
(mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
)
(alert "Routine is extremely slow - over 5 secs for a region (even more if over 100 regions) + you have to apply it on duplicates that are exact visual match in order for routine to do what it's supposed to, so please reconsider if you want to use it - use it only if you have no other better choice...")
(setq *adoc* (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark *adoc*)
(if (eq (getvar 'worlducs) 0)
(progn
(command "_.UCS" "_W")
(setq ucsf t)
)
)
(initget 6)
(setq fuzzar (getreal "\nFuzz factor of difference between testing area values <0.1> : "))
(if (null fuzzar) (setq fuzzar 0.1))
(initget 6)
(setq fuzzce (getreal "\nFuzz factor of distance between testing centroids <0.1> : "))
(if (null fuzzce) (setq fuzzce 0.1))
(prompt "\nSelect regions for kill operation")
(setq ss (ssget "_:L" '((0 . "REGION"))))
(setq i -1 ii -1 zz -1 kk 0 sss (ssadd))
(repeat (sslength ss)
(ssadd (ssname ss (setq i (1+ i))) sss)
)
(if ss
(progn
(while (setq reg (ssname ss (setq ii (1+ ii))))
(setq ar (vla-get-area (vlax-ename->vla-object reg)))
(setq n (vlax-safearray->list (vlax-variant-value (vla-get-normal (vlax-ename->vla-object reg)))))
(if (equal (v^v n '(0.0 0.0 1.0)) '(0.0 0.0 0.0) 1e-6)
(setq x '(1.0 0.0 0.0) y '(0.0 1.0 0.0))
(setq x (unit (v^v n '(0.0 0.0 1.0))) y (unit (v^v n x)))
)
(command "_.explode" reg)
(while
(> (getvar 'cmdactive) 0)
(command "")
)
(setq p (vlax-curve-getstartpoint (entlast)))
(command "_.undo")
(while
(> (getvar 'cmdactive) 0)
(command "")
)
(setq ucs (vla-add (vla-get-usercoordinatesystems *adoc*) (vlax-3d-point p) (vlax-3d-point (mapcar '+ p x)) (vlax-3d-point (mapcar '+ p y)) "{ UCS }"))
(vla-put-activeucs *adoc* ucs)
(command "_.UCS" "_D" "{ UCS }")
(vlax-release-object ucs)
(setq ce (trans (vlax-safearray->list (vlax-variant-value (vla-get-centroid (vlax-ename->vla-object reg)))) 1 0))
(while (not (eq (getvar 'worlducs) 1))
(command "_.UCS" "_P")
)
(foreach iii (vl-remove ii (if (null (nolst zz (if sss (1- (sslength sss)) zz))) (list ii) (nolst zz (if sss (1- (sslength sss)) zz))))
(setq regtst (ssname ss iii))
(setq art (vla-get-area (vlax-ename->vla-object regtst)))
(setq n (vlax-safearray->list (vlax-variant-value (vla-get-normal (vlax-ename->vla-object regtst)))))
(if (equal (v^v n '(0.0 0.0 1.0)) '(0.0 0.0 0.0) 1e-6)
(setq x '(1.0 0.0 0.0) y '(0.0 1.0 0.0))
(setq x (unit (v^v n '(0.0 0.0 1.0))) y (unit (v^v n x)))
)
(command "_.explode" regtst)
(while
(> (getvar 'cmdactive) 0)
(command "")
)
(setq p (vlax-curve-getstartpoint (entlast)))
(command "_.undo")
(while
(> (getvar 'cmdactive) 0)
(command "")
)
(setq ucs (vla-add (vla-get-usercoordinatesystems *adoc*) (vlax-3d-point p) (vlax-3d-point (mapcar '+ p x)) (vlax-3d-point (mapcar '+ p y)) "{ UCS }"))
(vla-put-activeucs *adoc* ucs)
(command "_.UCS" "_D" "{ UCS }")
(vlax-release-object ucs)
(setq cet (trans (vlax-safearray->list (vlax-variant-value (vla-get-centroid (vlax-ename->vla-object regtst)))) 1 0))
(while (not (eq (getvar 'worlducs) 1))
(command "_.UCS" "_P")
)
(if
(and
(equal ar art fuzzar)
(equal ce cet fuzzce)
)
(if (not (vl-position reg regs))
(setq regs (cons regtst regs))
)
)
(setq art nil cet nil)
)
)
(foreach reg regs
(setq kk (1+ kk))
(entdel reg)
)
)
)
(prompt "\nTotal : ")(princ kk)(prompt " duplicate-regions erased")
(*error* nil)
)

(defun c:overkill-regs ( / *error* nolst v^v unit *adoc* ucs ucsf fuzzar fuzzce ss i ii zz kk sss reg ar n x y p ce regtst art cet regs ) 
 
  (vl-load-com) 
 
  (defun *error* ( msg ) 
    (while (not (eq (getvar 'worlducs) 1)) 
      (command "_.UCS" "_P") 
    ) 
    (if ucsf (command "_.UCS" "_P")) 
    (vla-endundomark *adoc*) 
    (if msg (prompt msg)) 
    (princ) 
  ) 
 
  (defun nolst ( st en / lst ) 
    (repeat (- en st) 
      (setq st (1+ st)) 
      (setq lst (cons st lst)) 
    ) 
    (reverse lst) 
  ) 
 
  (defun v^v ( u v ) 
    (mapcar '(lambda ( s1 s2 a b ) (+ ((eval s1) (* (nth a u) (nth b v))) ((eval s2) (* (nth a v) (nth b u))))) '(+ - +) '(- + -) '(1 0 0) '(2 2 1)) 
  ) 
 
  (defun unit ( v ) 
    (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v) 
  ) 
 
  (alert "Routine is extremely slow - over 5 secs for a region (even more if over 100 regions) + you have to apply it on duplicates that are exact visual match in order for routine to do what it's supposed to, so please reconsider if you want to use it - use it only if you have no other better choice...") 
  (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))) 
  (vla-startundomark *adoc*) 
  (if (eq (getvar 'worlducs) 0) 
    (progn 
      (command "_.UCS" "_W") 
      (setq ucsf t) 
    ) 
  ) 
  (initget 6) 
  (setq fuzzar (getreal "\nFuzz factor of difference between testing area values <0.1> : ")) 
  (if (null fuzzar) (setq fuzzar 0.1)) 
  (initget 6) 
  (setq fuzzce (getreal "\nFuzz factor of distance between testing centroids <0.1> : ")) 
  (if (null fuzzce) (setq fuzzce 0.1)) 
  (prompt "\nSelect regions for kill operation") 
  (setq ss (ssget "_:L" '((0 . "REGION")))) 
  (setq i -1 ii -1 zz -1 kk 0 sss (ssadd)) 
  (repeat (sslength ss) 
    (ssadd (ssname ss (setq i (1+ i))) sss) 
  ) 
  (if ss 
    (progn 
      (while (setq reg (ssname ss (setq ii (1+ ii)))) 
        (setq ar (vla-get-area (vlax-ename->vla-object reg))) 
        (setq n (vlax-safearray->list (vlax-variant-value (vla-get-normal (vlax-ename->vla-object reg))))) 
        (if (equal (v^v n '(0.0 0.0 1.0)) '(0.0 0.0 0.0) 1e-6) 
          (setq x '(1.0 0.0 0.0) y '(0.0 1.0 0.0)) 
          (setq x (unit (v^v n '(0.0 0.0 1.0))) y (unit (v^v n x))) 
        ) 
        (command "_.explode" reg) 
        (while 
          (> (getvar 'cmdactive) 0) 
          (command "") 
        ) 
        (setq p (vlax-curve-getstartpoint (entlast))) 
        (command "_.undo") 
        (while 
          (> (getvar 'cmdactive) 0) 
          (command "") 
        ) 
        (setq ucs (vla-add (vla-get-usercoordinatesystems *adoc*) (vlax-3d-point p) (vlax-3d-point (mapcar '+ p x)) (vlax-3d-point (mapcar '+ p y)) "{ UCS }")) 
        (vla-put-activeucs *adoc* ucs) 
        (command "_.UCS" "_D" "{ UCS }") 
        (vlax-release-object ucs) 
        (setq ce (trans (vlax-safearray->list (vlax-variant-value (vla-get-centroid (vlax-ename->vla-object reg)))) 1 0)) 
        (while (not (eq (getvar 'worlducs) 1)) 
          (command "_.UCS" "_P") 
        ) 
        (foreach iii (vl-remove ii (if (null (nolst zz (if sss (1- (sslength sss)) zz))) (list ii) (nolst zz (if sss (1- (sslength sss)) zz)))) 
          (setq regtst (ssname ss iii)) 
          (setq art (vla-get-area (vlax-ename->vla-object regtst))) 
          (setq n (vlax-safearray->list (vlax-variant-value (vla-get-normal (vlax-ename->vla-object regtst))))) 
          (if (equal (v^v n '(0.0 0.0 1.0)) '(0.0 0.0 0.0) 1e-6) 
            (setq x '(1.0 0.0 0.0) y '(0.0 1.0 0.0)) 
            (setq x (unit (v^v n '(0.0 0.0 1.0))) y (unit (v^v n x))) 
          ) 
          (command "_.explode" regtst) 
          (while 
            (> (getvar 'cmdactive) 0) 
            (command "") 
          ) 
          (setq p (vlax-curve-getstartpoint (entlast))) 
          (command "_.undo") 
          (while 
            (> (getvar 'cmdactive) 0) 
            (command "") 
          ) 
          (setq ucs (vla-add (vla-get-usercoordinatesystems *adoc*) (vlax-3d-point p) (vlax-3d-point (mapcar '+ p x)) (vlax-3d-point (mapcar '+ p y)) "{ UCS }")) 
          (vla-put-activeucs *adoc* ucs) 
          (command "_.UCS" "_D" "{ UCS }") 
          (vlax-release-object ucs) 
          (setq cet (trans (vlax-safearray->list (vlax-variant-value (vla-get-centroid (vlax-ename->vla-object regtst)))) 1 0)) 
          (while (not (eq (getvar 'worlducs) 1)) 
            (command "_.UCS" "_P") 
          ) 
          (if 
            (and 
              (equal ar art fuzzar) 
              (equal ce cet fuzzce) 
            ) 
            (if (not (vl-position reg regs)) 
              (setq regs (cons regtst regs)) 
            ) 
          ) 
          (setq art nil cet nil) 
        ) 
      ) 
      (foreach reg regs 
        (setq kk (1+ kk)) 
        (entdel reg) 
      ) 
    ) 
  ) 
  (prompt "\nTotal : ")(princ kk)(prompt " duplicate-regions erased") 
  (*error* nil) 
)

4、对于3DSOLIDS的OVERKILL:

游客，如果您要查看本帖隐藏内容请回复

q3_2006 · 发表于 2017-7-18 22:23:04

这个强大,不知道效率怎么样..

zixuan203344 · 发表于 2017-7-18 22:26:38

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

ynhh · 发表于 2017-7-19 07:46:36

太复杂了
谢谢领导

HLCAD · 发表于 2017-7-19 07:55:23

感谢大师分享代码！！！

waterchen · 发表于 2017-7-19 09:39:23

好强大的程序，谢谢分享！

fangmin723 · 发表于 2017-8-2 15:10:56

谢谢大师无私！

xinxirong · 发表于 2017-9-6 19:49:44

#在这里对于3DSOLIDS的OVERKILL:快速回复#

dnbcgrass · 发表于 2017-9-6 22:38:13

回复学习学习！

/db_自贡黄明儒_ · 发表于 2017-10-1 22:43:47

对于没有装ET工具时，很有用。感谢分享。

sicky111 · 发表于 2017-10-2 00:04:13

谢谢分享。

lifei1979 · 发表于 2017-11-16 23:12:05

这个强大,不知道效率怎么

434939575 · 发表于 2018-2-28 22:29:44

看下这个高级命令!谢谢老大！

sicky111 · 发表于 2018-3-1 00:01:33

太强大了。

负债累累 · 发表于 2018-3-1 03:48:43

感谢大师分享代码！！

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

[每日一码] 对于曲线、点、REGIONS、3DSOLID的OVERKILL实现代码

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分