网上收集来的重线删除程序望改进
本帖最后由 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))
)
) express tools 里面不是有overkill命令么，这个和overkill的区别是？ 好东西，谢谢楼主 可以用，研究一下 高手请出手，这个功能还是很实用的。 这个非常好用！比那些故作高深发带一大堆自己函数的所谓源码的高手好多了，谢谢了！ 这个程序好！！！ 这个正好需要 这个最大的遗憾就是，分解了多段线，丢失了宽度！！！！！ 新人学习中 不错，谢谢，很好用
不错，谢谢，很好用
多谢楼主，正好用！
页:
[1]
2