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

钾肥

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

my_autocad

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

小小的人

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

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

至今没学会

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

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

HuaiYu

请试用，希望多提意见!!

(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

去www.10house.net下载一个Ycut，里面就有“删重”功能

liushengri

我在CAD2004中运行,出现:  

错误: no function definition: VLAX-GET-ACAD-OBJECT

为什么?能改正吗？

zwd0077

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

flfcegu168

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

CAD83

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

钾肥

很久以前发的帖子，没想到今天来逛论坛居然浮上来了~

很多问题都是在工作中遇到，但是当时没办法解决，只是记了下来把问题贴了上来，后来也没去跟踪。真是惭愧。

愧对热心回答我的问题的兄弟，愧对各位大虾的一片热诚之心呀~

面壁……

liuhoujun

好东西!顶一下