Jump to content

I need overkill and ncopy !please help me!

lucas3

By lucas3
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

dbroada Grand Master

dbroada

Posted
Posted

One thing that would worry me, I know AutoDesk don't warranty any of their products but I would feel much happier telling my boss that the error occurred while using an AutoDesk supplied product than one I had begged off the internet.

  • Replies 44
  • Created
  • Last Reply

Top Posters In This Topic

  • marko_ribar

    14

  • ReMark

    7

  • lucas3

    6

  • flyfox1047

    5

Popular Days

Top Posters In This Topic

Popular Days

Dana W Grand Master

Dana W

Posted
Posted

One other thing that comes to mind. What is the first thing that turns up missing in hacked copies of AutoCad? That is usually Express Tools, right?

Debalance Enthusiast

Debalance

Posted
Posted
Instead of OVERKILL, you could just use DUPREM.lsp from here :

http://www.cadtutor.net/forum/showthread.php?83657-I-need-overkill-and-ncopy-!please-help-me!&p=#9

 

and edo0l.lsp from here :

http://www.cadtutor.net/forum/showthread.php?83675-Merry-Christmas%EF%BC%8CI-need-help!&p=#3

 

They are totally free, and ab speed I think its satisfactory...

This is quick and dirty code. And that's why it's free.

marko_ribar Veteran

marko_ribar

Posted
Posted
This is quick and dirty code. And that's why it's free.

 

Quick or dirty, but it works and it's free. I supose you offer something better that's free?

Debalance Enthusiast

Debalance

Posted
Posted
I supose you offer something better that's free?

Yes of course! Compared to the cost of AutoCAD my offer almost free. But much better than free...

marko_ribar Veteran

marko_ribar

Posted
Posted (edited)

Here is arckill.lsp - very similar to linekill.lsp posted in above link:

 

(defun unique ( lst )
 (if lst (cons (car lst) (vl-remove-if '(lambda ( x ) (equal (car lst) x 1e-) (unique (cdr lst)))))
)

(defun onarc-p ( p1 p p2 )
 (if (> p2 p1)
   (and (or (> p2 p) (equal p2 p 1e-) (or (> p p1) (equal p p1 1e-))
   (if (and (>= p 0.0) (<= p pi)) (or (> p2 p) (equal p2 p 1e-) (or (> p p1) (equal p p1 1e-))
 )
)

(defun erasedupoverarc ( ss / i arc p1 p2 c r dxf210 lay col62 col420 arclst arclsta arclstn arclstnn )
 (setq i -1)
 (while (setq arc (ssname ss (setq i (1+ i))))
   (setq p1 (cdr (assoc 50 (entget arc)))
         p2 (cdr (assoc 51 (entget arc)))
         c (cdr (assoc 10 (entget arc)))
         r (cdr (assoc 40 (entget arc)))
         dxf210 (cdr (assoc 210 (entget arc)))
         lay (cdr (assoc 8 (entget arc)))
         col62 (if (assoc 62 (entget arc)) (cdr (assoc 62 (entget arc))) nil)
         col420 (if (assoc 420 (entget arc)) (cdr (assoc 420 (entget arc))) nil)
   )
   (setq arclsta (cons (list p1 p2 c r dxf210 lay col62 col420) arclsta))
   (entdel arc)
 )
 (setq arclstn arclsta)
 (foreach arc arclsta
   (if (and (not (vl-member-if '(lambda ( x ) (and (equal (car x) (car arc) 1e- (equal (cadr x) (cadr arc) 1e- (equal (caddr x) (caddr arc) 1e- (equal (cadddr x) (cadddr arc) 1e- (equal (car (cddddr x)) (car (cddddr arc)) 1e-)) (vl-remove arc arclsta)))
            (vl-member-if '(lambda ( x ) (and (onarc-p (car x) (car arc) (cadr x)) (onarc-p (car x) (cadr arc) (cadr x)) (equal (caddr x) (caddr arc) 1e- (equal (cadddr x) (cadddr arc) 1e- (equal (car (cddddr x)) (car (cddddr arc)) 1e-)) (vl-remove arc arclsta))
       )
     (setq arclstn (vl-remove arc arclstn))
   )
 )
 (foreach arc arclstn
   (setq arclst (cons (list (nth 0 arc) (nth 1 arc) (nth 2 arc) (nth 3 arc) (nth 4 arc)) arclst))
 )
 (setq arclst (unique arclst))
 (foreach arc arclst
   (vl-some '(lambda ( x ) (if (and (equal (car x) (car arc) 1e- (equal (cadr x) (cadr arc) 1e- (equal (caddr x) (caddr arc) 1e- (equal (cadddr x) (cadddr arc) 1e- (equal (car (cddddr x)) (car (cddddr arc)) 1e-) (setq arclstnn (cons x arclstnn)))) arclstn)
 )
 (foreach arc arclstnn
   (entmake (vl-remove nil (list '(0 . "ARC") (cons 8 (nth 5 arc)) (if (nth 6 arc) (cons 62 (nth 6 arc))) (if (nth 7 arc) (cons 420 (nth 7 arc))) (cons 10 (nth 2 arc)) (cons 40 (nth 3 arc)) (cons 210 (nth 4 arc)) (cons 50 (car arc)) (cons 51 (cadr arc)))))
 )
 (- (length arclsta) (length arclstnn))
)

(defun c:eraseduparcs-overarcs-0arcs ( / ss s i k arc )
 (vl-load-com)
 (setq ss (ssget "_:L" '((0 . "ARC"))))
 (setq s (ssadd))
 (setq i -1)
 (setq k 0)
 (while (setq arc (ssname ss (setq i (1+ i))))
   (if (equal (- (vlax-curve-getdistatpoint arc (vlax-curve-getendpoint arc)) (vlax-curve-getdistatpoint arc (vlax-curve-getstartpoint arc))) 0.0 1e-4) (progn (setq k (1+ k)) (entdel arc)) (ssadd arc s))
 )
 (prompt "\nTotal : ")(princ (erasedupoverarc s))(prompt " duplicate-arcs erased")
 (prompt "\nTotal : ")(princ k)(prompt " zero-arcs erased")
 (princ)
)

(defun c:edo0a nil (c:eraseduparcs-overarcs-0arcs))

M.R.

Edited by marko_ribar
marko_ribar Veteran

marko_ribar

Posted
Posted (edited)

And here is plineskill.lsp - combination of lineskill.lsp and arcskill.lsp:

 

(defun _unique ( linlst )
 (if (car linlst) (cons (car linlst) (_unique (_vl-remove (car linlst) (_vl-remove (list (cadar linlst) (caar linlst)) (cdr linlst) 1e-6) 1e-6))))
)

(defun _vl-remove ( el lst fuzz )
 (vl-remove-if '(lambda ( x ) (and (equal (car x) (car el) fuzz) (equal (cadr x) (cadr el) fuzz))) lst)
)

(defun online-p ( p1 p p2 )
 (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-
)

(defun erasedupoverlin ( ss / i lin p1 p2 lay col62 col420 linlst linlsta linlstn ssss1 )
 (setq i -1)
 (while (setq lin (ssname ss (setq i (1+ i))))
   (setq p1 (cdr (assoc 10 (entget lin)))
         p2 (cdr (assoc 11 (entget lin)))
         lay (cdr (assoc 8 (entget lin)))
         col62 (if (assoc 62 (entget lin)) (cdr (assoc 62 (entget lin))) nil)
         col420 (if (assoc 420 (entget lin)) (cdr (assoc 420 (entget lin))) nil)
   )
   (setq linlsta (cons (list p1 p2 lay col62 col420) linlsta))
   (setq linlst (cons (list p1 p2) linlst))
   (entdel lin)
 )
 (setq linlstn (_unique linlst))
 (foreach lin linlstn
   (if (vl-some '(lambda ( x ) (and (online-p (car x) (car lin) (cadr x)) (online-p (car x) (cadr lin) (cadr x)) (not (or (equal x lin 1e- (equal x (list (cadr lin) (car lin)) 1e-)))) linlstn)
     (setq linlstn (vl-remove lin linlstn))
   )
 )
 (foreach lin linlsta
   (if (vl-some '(lambda ( x ) (and (equal (car x) (car lin) 1e- (equal (cadr x) (cadr lin) 1e-)) linlstn)
     (setq linlstn (subst lin (list (car lin) (cadr lin)) linlstn))
   )
 )
 (setq ssss1 (ssadd))
 (foreach lin linlstn
   (ssadd (entmakex (vl-remove nil (list '(0 . "LINE") (cons 8 (caddr lin)) (if (cadddr lin) (cons 62 (cadddr lin))) (if (caddr (cddr lin)) (cons 420 (caddr (cddr lin)))) (cons 10 (car lin)) (cons 11 (cadr lin))))) ssss1)
 )
 ssss1
)

(defun unique ( lst )
 (if lst (cons (car lst) (vl-remove-if '(lambda ( x ) (equal (car lst) x 1e-) (unique (cdr lst)))))
)

(defun onarc-p ( p1 p p2 )
 (if (> p2 p1)
   (and (or (> p2 p) (equal p2 p 1e-) (or (> p p1) (equal p p1 1e-))
   (if (and (>= p 0.0) (<= p pi)) (or (> p2 p) (equal p2 p 1e-) (or (> p p1) (equal p p1 1e-))
 )
)

(defun erasedupoverarc ( ss / i arc p1 p2 c r dxf210 lay col62 col420 arclst arclsta arclstn arclstnn ssss2 )
 (setq i -1)
 (while (setq arc (ssname ss (setq i (1+ i))))
   (setq p1 (cdr (assoc 50 (entget arc)))
         p2 (cdr (assoc 51 (entget arc)))
         c (cdr (assoc 10 (entget arc)))
         r (cdr (assoc 40 (entget arc)))
         dxf210 (cdr (assoc 210 (entget arc)))
         lay (cdr (assoc 8 (entget arc)))
         col62 (if (assoc 62 (entget arc)) (cdr (assoc 62 (entget arc))) nil)
         col420 (if (assoc 420 (entget arc)) (cdr (assoc 420 (entget arc))) nil)
   )
   (setq arclsta (cons (list p1 p2 c r dxf210 lay col62 col420) arclsta))
   (entdel arc)
 )
 (setq arclstn arclsta)
 (foreach arc arclsta
   (if (and (not (vl-member-if '(lambda ( x ) (and (equal (car x) (car arc) 1e- (equal (cadr x) (cadr arc) 1e- (equal (caddr x) (caddr arc) 1e- (equal (cadddr x) (cadddr arc) 1e- (equal (car (cddddr x)) (car (cddddr arc)) 1e-)) (vl-remove arc arclsta)))
            (vl-member-if '(lambda ( x ) (and (onarc-p (car x) (car arc) (cadr x)) (onarc-p (car x) (cadr arc) (cadr x)) (equal (caddr x) (caddr arc) 1e- (equal (cadddr x) (cadddr arc) 1e- (equal (car (cddddr x)) (car (cddddr arc)) 1e-)) (vl-remove arc arclsta))
       )
     (setq arclstn (vl-remove arc arclstn))
   )
 )
 (foreach arc arclstn
   (setq arclst (cons (list (nth 0 arc) (nth 1 arc) (nth 2 arc) (nth 3 arc) (nth 4 arc)) arclst))
 )
 (setq arclst (unique arclst))
 (foreach arc arclst
   (vl-some '(lambda ( x ) (if (and (equal (car x) (car arc) 1e- (equal (cadr x) (cadr arc) 1e- (equal (caddr x) (caddr arc) 1e- (equal (cadddr x) (cadddr arc) 1e- (equal (car (cddddr x)) (car (cddddr arc)) 1e-) (setq arclstnn (cons x arclstnn)))) arclstn)
 )
 (setq ssss2 (ssadd))
 (foreach arc arclstnn
   (ssadd (entmakex (vl-remove nil (list '(0 . "ARC") (cons 8 (nth 5 arc)) (if (nth 6 arc) (cons 62 (nth 6 arc))) (if (nth 7 arc) (cons 420 (nth 7 arc))) (cons 10 (nth 2 arc)) (cons 40 (nth 3 arc)) (cons 210 (nth 4 arc)) (cons 50 (car arc)) (cons 51 (cadr arc))))) ssss2)
 )
 ssss2
)

(defun erasedupoverplin ( ss / i ssr ssrr sss ssss plin ssl ssa ent sssss )
 (setq i -1)
 (setq sss (ssadd))
 (if (> (sslength ss) 0)
   (progn
     (setq ssr (acet-ss-remove ss (ssget "_X" (list '(0 . "*POLYLINE") '(-4 . "<not") '(-4 . "&=") '(70 .  '(-4 . "not>") (cons 410 (getvar 'ctab))))))
     (while (setq plin (ssname ss (setq i (1+ i))))
       (command "_.explode" plin)
       (while (> (getvar 'cmdactive) 0) (command ""))
       (setq ssss (ssget "_P"))
       (setq sss (acet-ss-union (list sss ssss)))
     )
     (setq i -1)
     (setq ssl (ssadd) ssa (ssadd))
     (while (setq ent (ssname sss (setq i (1+ i))))
       (if (eq (cdr (assoc 0 (entget ent))) "LINE")
         (ssadd ent ssl)
         (ssadd ent ssa)
       )
     )
     (setq sssss (acet-ss-union (list (erasedupoverlin ssl) (erasedupoverarc ssa))))
     (if sssss (command "_.pedit" "_m" sssss "" "_j" "" ""))
   )
 )
 (if (null ssr) (setq ssr (ssadd)))
 (if (ssget "_X" (list '(0 . "*POLYLINE") '(-4 . "<not") '(-4 . "&=") '(70 .  '(-4 . "not>") (cons 410 (getvar 'ctab)))) (setq ssrr (ssget "_X" (list '(0 . "*POLYLINE") '(-4 . "<not") '(-4 . "&=") '(70 .  '(-4 . "not>") (cons 410 (getvar 'ctab))))) (setq ssrr (ssadd)))
 (- (sslength ss) (sslength (if (acet-ss-remove ssr ssrr) (acet-ss-remove ssr ssrr) (ssadd))))
)

(defun c:erasedupplines-overplines-0plines ( / pea ss s i k plin plptlst v )
 (setvar 'cecolor "ByLayer")
 (setq pea (getvar 'peditaccept))
 (setvar 'peditaccept 1)
 (setq ss (ssget "_:L" (list '(0 . "*POLYLINE") '(-4 . "<not") '(-4 . "&=") '(70 .  '(-4 . "not>"))))
 (setq s (ssadd))
 (setq i -1)
 (setq k 0)
 (while (setq plin (ssname ss (setq i (1+ i))))
   (cond 
     ( (eq (cdr (assoc 0 (entget plin))) "LWPOLYLINE")
       (setq plptlst (mapcar 'cdr (acet-list-m-assoc 10 (entget plin))))
       (if (vl-every '(lambda ( x ) (equal (car plptlst) x 1e-6)) plptlst)
         (progn
           (setq plptlst nil)
           (setq k (1+ k))
           (entdel plin)
         )
         (ssadd plin s)
       )
     )
     ( (eq (cdr (assoc 0 (entget plin))) "POLYLINE")
       (setq v plin)
       (while (eq (cdr (assoc 0 (entget (setq v (entnext v))))) "VERTEX")
         (setq plptlst (cons (cdr (assoc 10 (entget v))) plptlst))
       )
       (if (vl-every '(lambda ( x ) (equal (car plptlst) x 1e-6)) plptlst)
         (progn
           (setq plptlst nil)
           (setq k (1+ k))
           (entdel plin)
         )
         (ssadd plin s)
       )
     )
   )
 )
 (prompt "\nTotal : ")(princ (erasedupoverplin s))(prompt " duplicate-plines erased")
 (prompt "\nTotal : ")(princ k)(prompt " zero-plines erased")
 (setvar 'peditaccept pea)
 (princ)
)

(defun c:edo0pl nil (c:erasedupplines-overplines-0plines))

Regards, all the best, M.R.

BTW., HTH.

Edited by marko_ribar
flyfox1047 Enthusiast

flyfox1047

Posted
Posted

Wow! Wrote so many！ DUPREM.lsp not yet ? marko_ribar ,I think you should help me, have a look at post #12

marko_ribar Veteran

marko_ribar

Posted
Posted (edited)

Here is final 3D plineskill.lsp... Only lack of the code is that during execution it creates named UCSs by this array (1, 2, 3, ...)... So if you have UCS named "1" or "2" ... and you want to plineskill3D, you should firstly empty those UCS names... Upon execution of routine, all previously named UCSs are deleted...

 

(defun _unique ( linlst )
 (if (car linlst) (cons (car linlst) (_unique (_vl-remove (car linlst) (_vl-remove (list (cadar linlst) (caar linlst)) (cdr linlst) 1e-6) 1e-6))))
)

(defun _vl-remove ( el lst fuzz )
 (vl-remove-if '(lambda ( x ) (and (equal (car x) (car el) fuzz) (equal (cadr x) (cadr el) fuzz))) lst)
)

(defun online-p ( p1 p p2 )
 (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-
)

(defun erasedupoverlin ( ss / i lin p1 p2 lay col62 col420 linlst linlsta linlstn ssss1 )
 (setq i -1)
 (while (setq lin (ssname ss (setq i (1+ i))))
   (setq p1 (cdr (assoc 10 (entget lin)))
         p2 (cdr (assoc 11 (entget lin)))
         lay (cdr (assoc 8 (entget lin)))
         col62 (if (assoc 62 (entget lin)) (cdr (assoc 62 (entget lin))) nil)
         col420 (if (assoc 420 (entget lin)) (cdr (assoc 420 (entget lin))) nil)
   )
   (setq linlsta (cons (list p1 p2 lay col62 col420) linlsta))
   (setq linlst (cons (list p1 p2) linlst))
   (entdel lin)
 )
 (setq linlstn (_unique linlst))
 (foreach lin linlstn
   (if (vl-some '(lambda ( x ) (and (online-p (car x) (car lin) (cadr x)) (online-p (car x) (cadr lin) (cadr x)) (not (or (equal x lin 1e- (equal x (list (cadr lin) (car lin)) 1e-)))) linlstn)
     (setq linlstn (vl-remove lin linlstn))
   )
 )
 (foreach lin linlsta
   (if (vl-some '(lambda ( x ) (and (equal (car x) (car lin) 1e- (equal (cadr x) (cadr lin) 1e-)) linlstn)
     (setq linlstn (subst lin (list (car lin) (cadr lin)) linlstn))
   )
 )
 (setq ssss1 (ssadd))
 (foreach lin linlstn
   (ssadd (entmakex (vl-remove nil (list '(0 . "LINE") (cons 8 (caddr lin)) (if (cadddr lin) (cons 62 (cadddr lin))) (if (caddr (cddr lin)) (cons 420 (caddr (cddr lin)))) (cons 10 (car lin)) (cons 11 (cadr lin))))) ssss1)
 )
 ssss1
)

(defun unique ( lst )
 (if lst (cons (car lst) (vl-remove-if '(lambda ( x ) (equal (car lst) x 1e-) (unique (cdr lst)))))
)

(defun onarc-p ( p1 p p2 )
 (if (> p2 p1)
   (and (or (> p2 p) (equal p2 p 1e-) (or (> p p1) (equal p p1 1e-))
   (if (and (>= p 0.0) (<= p pi)) (or (> p2 p) (equal p2 p 1e-) (or (> p p1) (equal p p1 1e-))
 )
)

(defun erasedupoverarc ( ss / i arc p1 p2 c r dxf210 lay col62 col420 arclst arclsta arclstn arclstnn ssss2 )
 (setq i -1)
 (while (setq arc (ssname ss (setq i (1+ i))))
   (setq p1 (cdr (assoc 50 (entget arc)))
         p2 (cdr (assoc 51 (entget arc)))
         c (cdr (assoc 10 (entget arc)))
         r (cdr (assoc 40 (entget arc)))
         dxf210 (cdr (assoc 210 (entget arc)))
         lay (cdr (assoc 8 (entget arc)))
         col62 (if (assoc 62 (entget arc)) (cdr (assoc 62 (entget arc))) nil)
         col420 (if (assoc 420 (entget arc)) (cdr (assoc 420 (entget arc))) nil)
   )
   (setq arclsta (cons (list p1 p2 c r dxf210 lay col62 col420) arclsta))
   (entdel arc)
 )
 (setq arclstn arclsta)
 (foreach arc arclsta
   (if (and (not (vl-member-if '(lambda ( x ) (and (equal (car x) (car arc) 1e- (equal (cadr x) (cadr arc) 1e- (equal (caddr x) (caddr arc) 1e- (equal (cadddr x) (cadddr arc) 1e- (equal (car (cddddr x)) (car (cddddr arc)) 1e-)) (vl-remove arc arclsta)))
            (vl-member-if '(lambda ( x ) (and (onarc-p (car x) (car arc) (cadr x)) (onarc-p (car x) (cadr arc) (cadr x)) (equal (caddr x) (caddr arc) 1e- (equal (cadddr x) (cadddr arc) 1e- (equal (car (cddddr x)) (car (cddddr arc)) 1e-)) (vl-remove arc arclsta))
       )
     (setq arclstn (vl-remove arc arclstn))
   )
 )
 (foreach arc arclstn
   (setq arclst (cons (list (nth 0 arc) (nth 1 arc) (nth 2 arc) (nth 3 arc) (nth 4 arc)) arclst))
 )
 (setq arclst (unique arclst))
 (foreach arc arclst
   (vl-some '(lambda ( x ) (if (and (equal (car x) (car arc) 1e- (equal (cadr x) (cadr arc) 1e- (equal (caddr x) (caddr arc) 1e- (equal (cadddr x) (cadddr arc) 1e- (equal (car (cddddr x)) (car (cddddr arc)) 1e-) (setq arclstnn (cons x arclstnn)))) arclstn)
 )
 (setq ssss2 (ssadd))
 (foreach arc arclstnn
   (ssadd (entmakex (vl-remove nil (list '(0 . "ARC") (cons 8 (nth 5 arc)) (if (nth 6 arc) (cons 62 (nth 6 arc))) (if (nth 7 arc) (cons 420 (nth 7 arc))) (cons 10 (nth 2 arc)) (cons 40 (nth 3 arc)) (cons 210 (nth 4 arc)) (cons 50 (car arc)) (cons 51 (cadr arc))))) ssss2)
 )
 ssss2
)

(defun erasedupoverplin ( ss / i ii k kk vec ssr ssrr sss ssss plin ssl ssa ent sssss sssssl sssssu )
 (setq i -1)
 (setq sss (ssadd))
 (if (> (sslength ss) 0)
   (progn
     (setq ssr (acet-ss-remove ss (ssget "_X" (list '(0 . "*POLYLINE") '(-4 . "<not") '(-4 . "&=") '(70 .  '(-4 . "not>") (cons 410 (getvar 'ctab))))))
     (setq k 0)
     (while (setq plin (ssname ss (setq i (1+ i))))
       (setq k (1+ k))
       (command "_.ucs" "_e" plin)
       (command "_.ucs" "_s" k)
       (command "_.explode" plin)
       (while (> (getvar 'cmdactive) 0) (command ""))
       (setq ssss (ssget "_P"))
       (setq sss (acet-ss-union (list sss ssss)))
     )
     (setq i -1)
     (setq ssl (ssadd) ssa (ssadd))
     (while (setq ent (ssname sss (setq i (1+ i))))
       (if (eq (cdr (assoc 0 (entget ent))) "LINE")
         (ssadd ent ssl)
         (ssadd ent ssa)
       )
     )
     (setq sssss (acet-ss-union (list (erasedupoverlin ssl) (erasedupoverarc ssa))))
     (setq i -1)
     (setq sssssl (ssadd))
     (if sssss
       (progn
         (while (setq ent (ssname sssss (setq i (1+ i))))
           (if (eq (cdr (assoc 0 (entget ent))) "LINE")
             (progn
               (setq kk 0)
               (setq vec (mapcar '- (cdr (assoc 11 (entget ent))) (cdr (assoc 10 (entget ent)))))
               (while (not (equal (caddr (trans vec 0 1 t)) 0.0 1e-6))
                 (setq kk (1+ kk))
                 (command "_.ucs" "_r" kk)
               )
               (command "_.pedit" ent "")
               (ssadd (entlast) sssssl)
             )
             (progn
               (setq kk 0)
               (while (not (equal (trans '(0.0 0.0 1.0) 1 0 t) (cdr (assoc 210 (entget ent))) 1e-6))
                 (setq kk (1+ kk))
                 (command "_.ucs" "_r" kk)
               )
               (command "_.pedit" ent "")
               (ssadd (entlast) sssssl)
             )
           )
         )
         (setq kk 0)
         (repeat k
           (setq kk (1+ kk))
           (setq sssssu (ssadd))
           (setq ii -1)
           (if sssssl
             (progn
               (while (setq ent (ssname sssssl (setq ii (1+ ii))))
                 (if (equal (trans '(0.0 0.0 1.0) 1 0 t) (cdr (assoc 210 (entget ent))) 1e-
                   (ssadd ent sssssu)
                 )
               )
               (if (> (sslength sssssu) 0) (command "_.pedit" "_m" sssssu "" "_j" "" ""))
               (setq sssssl (acet-ss-remove sssssu sssssl))
               (command "_.ucs" "_r" kk)
             )
           )
         )
         (setq kk 0)
         (repeat k
           (setq kk (1+ kk))
           (command "_.ucs" "_d" kk)
         )
       )
     )
   )
 )
 (if (null ssr) (setq ssr (ssadd)))
 (if (ssget "_X" (list '(0 . "*POLYLINE") '(-4 . "<not") '(-4 . "&=") '(70 .  '(-4 . "not>") (cons 410 (getvar 'ctab)))) (setq ssrr (ssget "_X" (list '(0 . "*POLYLINE") '(-4 . "<not") '(-4 . "&=") '(70 .  '(-4 . "not>") (cons 410 (getvar 'ctab))))) (setq ssrr (ssadd)))
 (- (sslength ss) (sslength (if (acet-ss-remove ssr ssrr) (acet-ss-remove ssr ssrr) (ssadd))))
)

(defun c:erasedupplines-overplines-0plines ( / pea ss s i k plin plptlst v )
 (setvar 'cecolor "ByLayer")
 (setq pea (getvar 'peditaccept))
 (setvar 'peditaccept 1)
 (setq ss (ssget "_:L" (list '(0 . "*POLYLINE") '(-4 . "<not") '(-4 . "&=") '(70 .  '(-4 . "not>"))))
 (setq s (ssadd))
 (setq i -1)
 (setq k 0)
 (while (setq plin (ssname ss (setq i (1+ i))))
   (cond 
     ( (eq (cdr (assoc 0 (entget plin))) "LWPOLYLINE")
       (setq plptlst (mapcar 'cdr (acet-list-m-assoc 10 (entget plin))))
       (if (vl-every '(lambda ( x ) (equal (car plptlst) x 1e-6)) plptlst)
         (progn
           (setq plptlst nil)
           (setq k (1+ k))
           (entdel plin)
         )
         (ssadd plin s)
       )
     )
     ( (eq (cdr (assoc 0 (entget plin))) "POLYLINE")
       (setq v plin)
       (while (eq (cdr (assoc 0 (entget (setq v (entnext v))))) "VERTEX")
         (setq plptlst (cons (cdr (assoc 10 (entget v))) plptlst))
       )
       (if (vl-every '(lambda ( x ) (equal (car plptlst) x 1e-6)) plptlst)
         (progn
           (setq plptlst nil)
           (setq k (1+ k))
           (entdel plin)
         )
         (ssadd plin s)
       )
     )
   )
 )
 (prompt "\nTotal : ")(princ (erasedupoverplin s))(prompt " duplicate-plines erased")
 (prompt "\nTotal : ")(princ k)(prompt " zero-plines erased")
 (setvar 'peditaccept pea)
 (command "_.ucs" "_w")
 (princ)
)

(defun c:edo0pl nil (c:erasedupplines-overplines-0plines))

M.R.

Edited by marko_ribar
marko_ribar Veteran

marko_ribar

Posted
Posted
Wow! Wrote so many！ DUPREM.lsp not yet ? marko_ribar ,I think you should help me, have a look at post #12

 

flyfox1047, I am not familiar with posted code and even very rarely I use "ncopy" command... I've completed tasks for "overkill" in my manner for benefit of all people that can find my codes useful, so that's all by me... Maybe someone else knows how to help you, after all this is what www is all about... Please, excuse me now, maybe later I'll find some time if someone tries to help and if I see where is the problem...

GP_ Rising Star

GP_

Posted
Posted
...marko_ribar ,I think you should help me, have a look at post #12 --> (...only single choice ,can you help me change to multi-choice?)

 

flyfox1047, I see in your profile that you use AutoCAD 2012, in this version NCOPY is a built-in command and already works this way.

 

 

Still remember:

 

Since Autocad2012 OVERKILL is a built-in command (very fast).
flyfox1047 Enthusiast

flyfox1047

Posted
Posted
flyfox1047, I see in your profile that you use AutoCAD 2012, in this version NCOPY is a built-in command and already works this way.

 

 

Still remember:

 

Yes , I know that ! I just casually ask，Sometimes I might use a lower version

flyfox1047 Enthusiast

flyfox1047

Posted
Posted
flyfox1047, I am not familiar with posted code and even very rarely I use "ncopy" command... I've completed tasks for "overkill" in my manner for benefit of all people that can find my codes useful, so that's all by me... Maybe someone else knows how to help you, after all this is what www is all about... Please, excuse me now, maybe later I'll find some time if someone tries to help and if I see where is the problem...

 

Oh! My friend，you too serious，it doesn't matter！I just casually ask.

  • 3 weeks later...
marko_ribar Veteran

marko_ribar

Posted
Posted (edited)

I decided to post what I use for OVERKILL - it's a combination of my newest code and built-in ACAD OVERKILL and PURGE commands...

 

(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 (member 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)
)

HTH, M.R.

Edited by marko_ribar
code changed - please verify it with tests
lucas3 Collaborator

lucas3

Posted
  • Author
Posted
I decided to post what I use for OVERKILL - it's a combination of my newest code and built-in ACAD OVERKILL and PURGE commands...

 

(defun c:OVERKILL-MR ( / adoc *error* nolst unique seg fuzz ss i k sss curve m pt ptlst ii zz kk iii curvetst ptt pttlst pttlstt ptlsttst 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)
 )

 (defun unique ( lst )
   (if lst (cons (car lst) (vl-remove (car lst) (unique (cdr 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 "_X" (list (cons 410 (getvar 'ctab)))) (command "_.-overkill" "all" "" "_o" fuzz "_i" "_a" "_p" "_y" ""))
 (prompt "\nSelect curves for curvekill operation")
 (setq ss (ssget "_:L"))
 (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))))))
         (setq ptlst (cons pt ptlst))
       )
       (setq ptlst (vl-remove nil ptlst))
       (if (vl-every '(lambda ( x ) (equal x pt 1e-4)) ptlst)
         (progn
           (entdel curve)
           (setq k (1+ k))
         )
         (ssadd curve sss)
       )
       (setq ptlst nil)
     )
     (setq ii -1)
     (setq zz -1)
     (if (/= (sslength sss) 0)
       (progn
         (while (setq curve (ssname sss (setq ii (1+ ii))))
           (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))))))
             (setq ptlst (cons pt ptlst))
           )
           (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))
             (foreach pt ptlst
               (setq ptt (vlax-curve-getclosestpointto curvetst pt))
               (setq pttlst (cons ptt pttlst))
             )
             (setq pttlst (reverse pttlst))
             (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))))))
               (setq ptlsttst (cons pt ptlsttst))
             )
             (foreach pt ptlsttst
               (setq ptt (vlax-curve-getclosestpointto curve pt))
               (setq pttlstt (cons ptt pttlstt))
             )
             (setq pttlstt (reverse pttlstt))
             (if (and (vl-every '(lambda ( a b ) (equal a b fuzz)) ptlst pttlst) (not (vl-every '(lambda ( a b ) (equal a b fuzz)) ptlsttst pttlstt)))
               (setq curves (cons curve curves))
             )
             (setq pttlst nil ptlsttst nil pttlstt nil)
           )
           (setq ptlst nil)
         )
         (foreach curve (unique 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)
 (princ)
)

HTH, M.R.

 

Hi,marko, Thank you! Can used before you update, now ,can't use!

marko_ribar Veteran

marko_ribar

Posted
Posted (edited)
Hi,marko, Thank you! Can used before you update, now ,can't use!

 

Lucas, I am using A2014 and it works fine on my comp... Try to change line with (command "_.-overkill") to suit your A2012... Maybe some options under A2012 OVERKILL command isn't the same - experiment for a while...

 

[EDIT : I've checked OVERKILL command under A2012 and they are the same as with A2014, so please describe your problem...]

 

M.R.

Edited by marko_ribar
EDIT comment
SLW210 Grand Master

SLW210

Posted
Posted

If you look at the Original Post, NO express tools loaded by the Original Poster lucas3.

marko_ribar Veteran

marko_ribar

Posted
Posted
If you look at the Original Post, NO express tools loaded by the Original Poster lucas3.

 

Oh, I overlooked that SLW210... But then again instead of OVERKILL, you can just use DUPREM.lsp by flyfox1047 posted in this thread earlier... Just replace OVERKILL line and supply needed arguments for DUPREM...

 

M.R.

lucas3 Collaborator

lucas3

Posted
  • Author
Posted
Oh, I overlooked that SLW210... But then again instead of OVERKILL, you can just use DUPREM.lsp by flyfox1047 posted in this thread earlier... Just replace OVERKILL line and supply needed arguments for DUPREM...

 

M.R.

 

Hi,marko,must install ET? If installed ET,Why not use the built-in OVERKIL ?

When you first publish，I test ,Just show some error information，But Can delete duplicate objects，Also, I don't have to install ET

When you edited ,I test ,Only error message，can't delete duplicate!

Sorry for my English! I hope you can understand！

marko_ribar Veteran

marko_ribar

Posted
Posted (edited)
Hi,marko,must install ET?

 

You don't need to install ET if you don't want to... Just remove line with (command "_.-overkill") and before you use OVERKILL-MR, use firstly DUPREM.lsp posted earlier by flyfox1047...

 

If installed ET,Why not use the built-in OVERKIL ?

 

Original OVERKILL command as far as I know don't deal with polylines and splines, and my code was made just for all this situations - it deals with all kind of overlapping curves... Only if curves are identical it will leave them unchanged, but that's why you have to use firstly DUPREM.lsp or original ET OVERKILL command...

 

When you first publish，I test ,Just show some error information，But Can delete duplicate objects，Also, I don't have to install ET

When you edited ,I test ,Only error message，can't delete duplicate!

 

This kind of error message isn't provided nowhere inside my code, so I doubt it comes from my routine... Disable line with (command "_.-overkill") if you don't have ET installed, or if you have it make sure you use A2012 and above A2013,A2014 software... Also my code prevents operating on objects that are supposed to be on locked layers, but maybe (command "_.-overkill") doesn't see this - it operates on "all" objects as supplied and if objects are locked then perhaps this is the source of error you are recieving...

 

Sorry for my English! I hope you can understand！

 

I tried to undertand as much as possible, but the part explaining your error message isn't written good enough...

 

M.R.

 

[EDIT: BTW., lucas, A2012 doesn't support those -PURGE commands that are not commented, so you should remove them too...]

Edited by marko_ribar
EDIT note

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...