[求助]清除DWG文件中重复的线！

钾肥发表于 2005-10-29 21:29:00

工作中DWG的图形文件中常常会出现一些乱七八糟的图纸，很多都是同一根线划了好几遍，而且是一个图层，有的甚至几条线相互重复起点和终点也不一样，哪位编个检测的程序，消除这种情况！

my_autocad 发表于 2008-2-26 17:08:00

CAD系统ET里带有一个程序，叫overkill的，应该够用了吧

小小的人 发表于 2020-5-8 21:22:04

HuaiYu 发表于 2005-11-4 23:29
请试用，希望多提意见!!
(defun c:t1 (/ old_osmode old_cmdecho ss ssLine ssArc)  (vl-load-com)&nb ...

非常好用谢谢你的分享之前找的都清理不干净你的试了一下清理的很干净

至今没学会 发表于 2020-5-6 17:03:08

HuaiYu 发表于 2005-11-4 23:29
请试用，希望多提意见!!
(defun c:t1 (/ old_osmode old_cmdecho ss ssLine ssArc)  (vl-load-com)&nb ...

大佬，你这个应该添加一下删除重复圆孔与弧的重复线删除，光删重复线有点那啥了:lol

HuaiYu 发表于 2005-11-4 23:29:00

请试用，希望多提意见!!
(defun c:t1 (/ 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))   ) )

10house 发表于 2005-11-8 18:07:00

去<A href="http://www.10house.net/" target="_blank" >www.10house.net</A>下载一个Ycut，里面就有“删重”功能

liushengri 发表于 2005-12-8 08:56:00

我在CAD2004中运行,出现:   
错误: no function definition: VLAX-GET-ACAD-OBJECT
为什么?能改正吗？

zwd0077 发表于 2005-12-17 16:02:00

二楼老大，有这样的VBA程序吗？

flfcegu168 发表于 2008-2-23 20:28:00

很好就是看能不能将重叠圆也删除就好先谢了

CAD83 发表于 2008-2-27 08:32:00

很好的一样啊，就是在2004用不了，可否改下啊，

钾肥发表于 2008-2-28 23:04:00

很久以前发的帖子，没想到今天来逛论坛居然浮上来了~ 很多问题都是在工作中遇到，但是当时没办法解决，只是记了下来把问题贴了上来，后来也没去跟踪。真是惭愧。 愧对热心回答我的问题的兄弟，愧对各位大虾的一片热诚之心呀~ 面壁……

liuhoujun 发表于 2008-4-1 10:25:00

好东西!顶一下

页: [1] 2 3

明经CAD社区's Archiver

[求助]清除DWG文件中重复的线！