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

;;修正了一个错误。
;;这个更快，可以连接线条。
;;消除合并重复线条
(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 (vla-object em)
       StartAngle (vla-Get-StartAngle vm)
       EndAngle  (vla-Get-EndAngle vm)
 )
 (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) (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))
  )
)