明经CAD社区

 找回密码
 注册

扫一扫,访问微社区

QQ登录

只需一步,快速开始

查看: 3083|回复: 12

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

[复制链接]
发表于 2013-6-17 18:46 | 显示全部楼层 |阅读模式
本帖最后由 hehoubin 于 2013-6-17 18:49 编辑

;希望整合成对话对话框的多功能版,并支持,块,弧,直线,多段线,圆,还有除块以外能转换成多段线。[code="lisp] ;;修正了一个错误。
;;这个更快,可以连接线条。
;;消除合并重复线条
(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))
  )
)[/code]

评分

参与人数 1明经币 +1 收起 理由
spp_wall + 1 很给力!

查看全部评分

本帖被以下淘专辑推荐:

发表于 2013-6-21 12:43 | 显示全部楼层
高手请出手,这个功能还是很实用的。
发表于 2013-11-21 20:30 | 显示全部楼层
这个非常好用!比那些故作高深发带一大堆自己函数的所谓源码的高手好多了,谢谢了!
发表于 2013-12-21 19:29 | 显示全部楼层
这个程序好!!!
发表于 2014-2-10 22:12 | 显示全部楼层
这个正好需要
发表于 2014-11-16 22:00 | 显示全部楼层
这个最大的遗憾就是,分解了多段线,丢失了宽度!!!!!
发表于 2015-8-24 10:22 | 显示全部楼层
新人学习中
发表于 2015-9-20 16:34 | 显示全部楼层
不错,谢谢,很好用
发表于 2015-9-30 11:12 | 显示全部楼层

不错,谢谢,很好用
发表于 2018-2-9 16:51 | 显示全部楼层
多谢楼主,正好用!
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号  
©2000-2017 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2018-10-21 11:50 , Processed in 0.228875 second(s), 32 queries , Gzip On.

Powered by Discuz! X3.3

© 2001-2013 Comsenz Inc.

快速回复 返回顶部 返回列表