网上收集来的重线删除程序望改进

hehoubin · 发表于 2013-6-17 18:46

本帖最后由 hehoubin 于 2013-6-17 18:49 编辑

；希望整合成对话对话框的多功能版，并支持，块，弧，直线，多段线，圆，还有除块以外能转换成多段线。

;;修正了一个错误。
;;这个更快，可以连接线条。
;;消除合并重复线条
(defun c:ovl (/ old_osmode old_cmdecho ss ssLine ssArc)
(vl-load-com)
(setq *AcadDocument* (vla-get-activeDocument (vlax-Get-Acad-Object)))
(vla-StartUndoMark *AcadDocument*)
(setq old_osmode (getvar "osmode")
old_cmdecho (getvar "cmdecho")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq ss (GetSelToUnite)
ssLine (car ss)
ssArc (cadr ss)
)
(setvar "osmode" 0)
(command ".ucs" "w")
(if (> (sslength ssLine) 1)
(UniteLine ssLine)
)
(if (> (sslength ssArc) 1)
(UniteArc ssArc)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (> (sslength ssLine) 0)
(pEdit ssLine)
)
(if (> (sslength ssArc) 0)
(pEdit ssArc)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setvar "osmode" old_osmode)
(setvar "cmdecho" old_cmdecho)
(vla-EndUndoMark *AcadDocument*)
(prin1)
)
(defun pedit (ss / i en vn startPt endPt ss1 ss2)
(setq i 0)
(repeat (sslength ss)
(setq en (ssname ss i)
i (1+ i)
)
(if (and (not (null (entget en))) (not (vlax-curve-isClosed (setq vn (vlax-ename->vla-object en)))))
(progn
(setq startPt (vlax-curve-GetStartPoint vn)
endPt (vlax-curve-GetEndPoint vn)
)
(setq ss1 (ssget "_c" (polar startPt (* pi 0.25) 0.01) (polar startPt (* pi 1.25) 0.01)))
(setq ss2 (ssget "_c" (polar endPt (* pi 0.25) 0.01) (polar endPt (* pi 1.25) 0.01)))
(if (equal (strcase (vla-Get-ObjectName vn)) (strcase "AcDbPolyline"))
(vl-cmdf "pedit" en "j" ss1 ss2 "")
(vl-cmdf "pedit" en "y" "j" ss1 ss2 "" "")
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun GetSelToUnite (/ ss1 ssArc ssLine ss1 ss i en ss2)
(setq ss1 (ssget "x")
ssArc (ssadd)
ssLine (ssadd)
ss (ssget '((0 . "line,lwpolyline,arc")))
i -1
)
(setvar "cmdecho" 0)
(repeat (sslength ss)
(setq en (ssname ss (setq i (1+ i))))
(if (equal (strcase (cdr (assoc 0 (entget en)))) (strcase "lwpolyline"))
(command "explode" en)
)
)
(setq ss2 (ssget "x")
i -1
)
(repeat (sslength ss2)
(setq en (ssname ss2 (setq i (1+ i))))
(if (or (not (ssmemb en ss1)) (ssmemb en ss))
(cond ((equal (cdr (assoc 0 (entget en))) (strcase "line")) (ssadd en ssLine))
((equal (cdr (assoc 0 (entget en))) (strcase "arc")) (ssadd en ssArc))
(t (princ "\n There is a error occured"))
)
)
)
(list ssLine ssArc)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun UniteArc (ss / i en)
(vla-StartUndoMark *AcadDocument*)
;;; (while (not (setq ss (ssget '((0 . "arc"))))))
(setq i 0)
(repeat (sslength ss)
(setq en (ssname ss i)
i (1+ i)
)
(if (not (null (entget en)))
(JoinArc en)
)
)
(vla-EndUndoMark *AcadDocument*)
)
;;;;;;;;;
(defun JoinArc (en / vn cenPt Radius AngLst i ss MinPt MaxPt StartAngle EndAngle em vm)
(setq vn (vlax-ename->vla-object en)
cenPt (cdr (assoc 10 (entget en)))
Radius (vla-get-radius vn)
AngLst '()
i -1
ss (ssadd)
)
(vla-GetBoundingBox vn 'MinPt 'MaxPt)
(setq MinPt (vlax-safearray->list MinPt)
MaxPt (vlax-safearray->list MaxPt)
)
(setq ss (ssget "c" MinPt MaxPt (list '(0 . "arc") (append (list 10) cenPt) (cons 40 Radius)))
ss (ssdel en ss)
)
(if ss
(progn
(setq StartAngle (vla-Get-StartAngle vn)
EndAngle (vla-Get-EndAngle vn)
)
(if (< EndAngle StartAngle)
(setq EndAngle (+ EndAngle (* pi 2.0)))
)
(setq AngLst (append AngLst (list StartAngle) (list EndAngle)))
(repeat (sslength ss)
(setq em (ssname ss (setq i (1+ i)))
vm (vlax-ename->vla-object em)
StartAngle (vla-Get-StartAngle vm)
EndAngle (vla-Get-EndAngle vm)
)
(if (< EndAngle StartAngle)
(setq EndAngle (+ EndAngle (* pi 2.0)))
)
(setq AngLst (append AngLst (list StartAngle) (list EndAngle)))
)
(setq AngLst (vl-sort AngLst '<))
(vl-cmdf "erase" ss "")
(vla-put-StartAngle vn (car AngLst))
(vla-put-EndAngle
vn
(if (> (last AngLst) (* pi 2))
(- (last AngLst) (* pi 2))
(last AngLst)
)
)
)
)
)
;;;;;;;;;(setq aa (vlax-ename->vla-object (car (entsel))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun UniteLine (ss / i en)
(vla-StartUndoMark *AcadDocument*)
;;; (while (not (setq ss (ssget '((0 . "line"))))))
(setq i 0)
(repeat (sslength ss)
(setq en (ssname ss i)
i (1+ i)
)
(if (not (null (entget en)))
(JoinLine en)
)
)
(vla-EndUndoMark *AcadDocument*)
(prin1)
)
(defun JoinLine (en / i lst_pt ang_en se ss em ang_em ssErase)
(setq i 0
lst_pt '()
ang_en (RetAng (angle (cdr (assoc 10 (entget en))) (cdr (assoc 11 (entget en)))))
;;; lst_pt (append lst_pt (list (cdr (assoc 10 (entget en)))) (list (cdr (assoc 11 (entget en)))))
)
(setq lst_pt (car (setq tmp (GetPtLst en)))
ssErase (cadr tmp)
)
(if (> (length lst_pt) 2)
(progn
(cond ((or (equal ang_en 0.0 0.001) (equal ang_en 180.0 0.001))
(setq lst_pt (vl-sort lst_pt '(lambda (e1 e2) (< (car e1) (car e2)))))
)
(t
(setq lst_pt (vl-sort lst_pt '(lambda (e1 e2) (< (cadr e1) (cadr e2)))))
)
)
(vla-put-startPoint (vlax-ename->vla-object en) (vlax-3d-point (car lst_pt)))
(vla-put-endPoint (vlax-ename->vla-object en) (vlax-3d-point (last lst_pt)))
(vl-cmdf "erase" ssErase "")
)
)
)
;;;;;;;;;;;
(defun GetPtLst (en / en_10 en_11 ang_en ptLst ss i em em_10 em_11 ang_em ang_10 ang_11)
(setq en_10 (cdr (assoc 10 (entget en)))
en_11 (cdr (assoc 11 (entget en)))
ang_en (RetAng (angle en_10 en_11))
ptLst (list en_10 en_11)
ssErase (ssadd)
)
(setq ss (ssget "c" en_10 en_11 '((0 . "line"))))
(if (> (sslength ss) 1)
(progn
(setq i -1)
(ssdel en ss)
(repeat (sslength ss)
(setq em (ssname ss (setq i (1+ i)))
em_10 (cdr (assoc 10 (entget em)))
em_11 (cdr (assoc 11 (entget em)))
ang_em (RetAng (angle em_10 em_11))
ang_10 (RetAng (angle en_10 em_10))
ang_11 (RetAng (angle en_10 em_11))
)
(if (and (equal ang_en ang_em 0.001) (or (equal ang_en ang_10 0.001) (equal ang_en ang_11 0.001)))
(setq ptLst (append ptLst (list em_10) (list em_11))
ssErase (ssadd em ssErase)
)
)
)
)
)
(list ptLst ssErase)
)
;;;;;;;;;;;
(defun RetAng (ang)
(if (>= ang (- pi 0.0001))
(atof (angtos (- ang pi) 0 4))
(atof (angtos ang 0 4))
)
)

;;修正了一个错误。 
;;这个更快，可以连接线条。 
;;消除合并重复线条 
(defun c:ovl (/ old_osmode old_cmdecho ss ssLine ssArc) 
  (vl-load-com) 
  (setq *AcadDocument* (vla-get-activeDocument (vlax-Get-Acad-Object))) 
  (vla-StartUndoMark *AcadDocument*) 
  (setq old_osmode  (getvar "osmode") 
 old_cmdecho (getvar "cmdecho") 
  ) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
  (setq ss     (GetSelToUnite) 
 ssLine (car ss) 
 ssArc  (cadr ss) 
  ) 
  (setvar "osmode" 0) 
  (command ".ucs" "w") 
 
  (if (> (sslength ssLine) 1) 
    (UniteLine ssLine) 
  ) 
  (if (> (sslength ssArc) 1) 
    (UniteArc ssArc) 
  ) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
  (if (> (sslength ssLine) 0) 
    (pEdit ssLine) 
  ) 
  (if (> (sslength ssArc) 0) 
    (pEdit ssArc) 
  ) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
  (setvar "osmode" old_osmode) 
  (setvar "cmdecho" old_cmdecho) 
  (vla-EndUndoMark *AcadDocument*) 
  (prin1) 
) 
(defun pedit (ss / i en vn startPt endPt ss1 ss2) 
  (setq i 0) 
  (repeat (sslength ss) 
    (setq en (ssname ss i) 
   i  (1+ i) 
    ) 
    (if (and (not (null (entget en))) (not (vlax-curve-isClosed (setq vn (vlax-ename->vla-object en))))) 
      (progn 
 (setq startPt (vlax-curve-GetStartPoint vn) 
       endPt   (vlax-curve-GetEndPoint vn) 
 ) 
 (setq ss1 (ssget "_c" (polar startPt (* pi 0.25) 0.01) (polar startPt (* pi 1.25) 0.01))) 
 (setq ss2 (ssget "_c" (polar endPt (* pi 0.25) 0.01) (polar endPt (* pi 1.25) 0.01))) 
 (if (equal (strcase (vla-Get-ObjectName vn)) (strcase "AcDbPolyline")) 
   (vl-cmdf "pedit" en "j" ss1 ss2 "") 
   (vl-cmdf "pedit" en "y" "j" ss1 ss2 "" "") 
 ) 
      ) 
    ) 
  ) 
) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun GetSelToUnite (/ ss1 ssArc ssLine ss1 ss i en ss2) 
  (setq ss1    (ssget "x") 
 ssArc  (ssadd) 
 ssLine (ssadd) 
 ss     (ssget '((0 . "line,lwpolyline,arc"))) 
 i      -1 
  ) 
  (setvar "cmdecho" 0) 
  (repeat (sslength ss) 
    (setq en (ssname ss (setq i (1+ i)))) 
    (if (equal (strcase (cdr (assoc 0 (entget en)))) (strcase "lwpolyline")) 
      (command "explode" en) 
    ) 
  ) 
  (setq ss2 (ssget "x") 
 i   -1 
  ) 
  (repeat (sslength ss2) 
    (setq en (ssname ss2 (setq i (1+ i)))) 
    (if (or (not (ssmemb en ss1)) (ssmemb en ss)) 
      (cond ((equal (cdr (assoc 0 (entget en))) (strcase "line")) (ssadd en ssLine)) 
     ((equal (cdr (assoc 0 (entget en))) (strcase "arc")) (ssadd en ssArc)) 
     (t (princ "\n There is a error occured")) 
      ) 
    ) 
  ) 
  (list ssLine ssArc) 
) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun UniteArc (ss / i en) 
  (vla-StartUndoMark *AcadDocument*) 
;;;  (while (not (setq ss (ssget '((0 . "arc")))))) 
  (setq i 0) 
  (repeat (sslength ss) 
    (setq en (ssname ss i) 
   i  (1+ i) 
    ) 
    (if (not (null (entget en))) 
      (JoinArc en) 
    ) 
  ) 
  (vla-EndUndoMark *AcadDocument*) 
) 
;;;;;;;;; 
(defun JoinArc (en / vn cenPt Radius AngLst i ss MinPt MaxPt StartAngle EndAngle em vm) 
  (setq vn     (vlax-ename->vla-object en) 
 cenPt  (cdr (assoc 10 (entget en))) 
 Radius (vla-get-radius vn) 
 AngLst '() 
 i      -1 
 ss     (ssadd) 
  ) 
  (vla-GetBoundingBox vn 'MinPt 'MaxPt) 
  (setq MinPt (vlax-safearray->list MinPt) 
 MaxPt (vlax-safearray->list MaxPt) 
  ) 
  (setq ss (ssget "c" MinPt MaxPt (list '(0 . "arc") (append (list 10) cenPt) (cons 40 Radius))) 
 ss (ssdel en ss) 
  ) 
  (if ss 
    (progn 
      (setq StartAngle (vla-Get-StartAngle vn) 
     EndAngle   (vla-Get-EndAngle vn) 
      ) 
      (if (< EndAngle StartAngle) 
 (setq EndAngle (+ EndAngle (* pi 2.0))) 
      ) 
      (setq AngLst (append AngLst (list StartAngle) (list EndAngle))) 
      (repeat (sslength ss) 
 (setq em  (ssname ss (setq i (1+ i))) 
       vm  (vlax-ename->vla-object em) 
       StartAngle (vla-Get-StartAngle vm) 
       EndAngle  (vla-Get-EndAngle vm) 
 ) 
 (if (< EndAngle StartAngle) 
   (setq EndAngle (+ EndAngle (* pi 2.0))) 
 ) 
 (setq AngLst (append AngLst (list StartAngle) (list EndAngle))) 
      ) 
      (setq AngLst (vl-sort AngLst '<)) 
      (vl-cmdf "erase" ss "") 
      (vla-put-StartAngle vn (car AngLst)) 
      (vla-put-EndAngle 
 vn 
 (if (> (last AngLst) (* pi 2)) 
   (- (last AngLst) (* pi 2)) 
   (last AngLst) 
 ) 
      ) 
    ) 
  ) 
) 
;;;;;;;;;(setq aa (vlax-ename->vla-object (car (entsel)))) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun UniteLine (ss / i en) 
  (vla-StartUndoMark *AcadDocument*) 
;;;  (while (not (setq ss (ssget '((0 . "line")))))) 
  (setq i 0) 
  (repeat (sslength ss) 
    (setq en (ssname ss i) 
   i  (1+ i) 
    ) 
    (if (not (null (entget en))) 
      (JoinLine en) 
    ) 
  ) 
  (vla-EndUndoMark *AcadDocument*) 
  (prin1) 
) 
(defun JoinLine (en / i lst_pt ang_en se ss em ang_em ssErase) 
  (setq i      0 
 lst_pt '() 
 ang_en (RetAng (angle (cdr (assoc 10 (entget en))) (cdr (assoc 11 (entget en))))) 
;;; lst_pt (append lst_pt (list (cdr (assoc 10 (entget en)))) (list (cdr (assoc 11 (entget en))))) 
  ) 
  (setq lst_pt (car (setq tmp (GetPtLst en))) 
 ssErase (cadr tmp) 
  ) 
  (if (> (length lst_pt) 2) 
    (progn 
      (cond ((or (equal ang_en 0.0 0.001) (equal ang_en 180.0 0.001)) 
      (setq lst_pt (vl-sort lst_pt '(lambda (e1 e2) (< (car e1) (car e2))))) 
     ) 
     (t 
      (setq lst_pt (vl-sort lst_pt '(lambda (e1 e2) (< (cadr e1) (cadr e2))))) 
     ) 
      ) 
      (vla-put-startPoint (vlax-ename->vla-object en) (vlax-3d-point (car lst_pt))) 
      (vla-put-endPoint (vlax-ename->vla-object en) (vlax-3d-point (last lst_pt))) 
      (vl-cmdf "erase" ssErase "") 
    ) 
  ) 
) 
;;;;;;;;;;; 
(defun GetPtLst (en / en_10 en_11 ang_en ptLst ss i em em_10 em_11 ang_em ang_10 ang_11) 
  (setq en_10 (cdr (assoc 10 (entget en))) 
 en_11 (cdr (assoc 11 (entget en))) 
 ang_en (RetAng (angle en_10 en_11)) 
 ptLst (list en_10 en_11) 
 ssErase (ssadd) 
  ) 
  (setq ss (ssget "c" en_10 en_11 '((0 . "line")))) 
  (if (> (sslength ss) 1) 
    (progn 
      (setq i -1) 
      (ssdel en ss) 
      (repeat (sslength ss) 
 (setq em     (ssname ss (setq i (1+ i))) 
       em_10  (cdr (assoc 10 (entget em))) 
       em_11  (cdr (assoc 11 (entget em))) 
       ang_em (RetAng (angle em_10 em_11)) 
       ang_10 (RetAng (angle en_10 em_10)) 
       ang_11 (RetAng (angle en_10 em_11)) 
 ) 
 (if (and (equal ang_en ang_em 0.001) (or (equal ang_en ang_10 0.001) (equal ang_en ang_11 0.001))) 
   (setq ptLst (append ptLst (list em_10) (list em_11)) 
  ssErase (ssadd em ssErase) 
   ) 
 ) 
      ) 
    ) 
  ) 
  (list ptLst ssErase) 
) 
;;;;;;;;;;; 
(defun RetAng (ang) 
  (if (>= ang (- pi 0.0001)) 
    (atof (angtos (- ang pi) 0 4)) 
    (atof (angtos ang 0 4)) 
  ) 
)

aurinel · 发表于 2018-4-2 10:50

express tools 里面不是有overkill命令么，这个和overkill的区别是？

buddhism8 · 发表于 2019-5-2 22:37

好东西，谢谢楼主

大展红图 · 发表于 2018-2-25 16:56

可以用，研究一下

fanqinwei · 发表于 2013-6-21 12:43

高手请出手，这个功能还是很实用的。

tender138 · 发表于 2013-11-21 20:30

这个非常好用！比那些故作高深发带一大堆自己函数的所谓源码的高手好多了，谢谢了！

spp_wall · 发表于 2013-12-21 19:29

这个程序好！！！

wwookl · 发表于 2014-2-10 22:12

这个正好需要

尘缘一生 · 发表于 2014-11-16 22:00

这个最大的遗憾就是，分解了多段线，丢失了宽度！！！！！

ltrliu · 发表于 2015-8-24 10:22

新人学习中

hehaidizhi · 发表于 2015-9-20 16:34

不错，谢谢，很好用

crab3 · 发表于 2015-9-30 11:12

不错，谢谢，很好用

eii · 发表于 2018-2-9 16:51

多谢楼主，正好用！

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

网上收集来的重线删除程序望改进

评分

本帖被以下淘专辑推荐:

相关帖子