一键连接相邻线段连接成多段线，如封闭则生成封闭多段线
(defun c:dxd( / sset i ent entpar dxf70)(setq sset (ssget (list (cons 0 "*line,arc"))))
(vl-cmdf "undo" "be")
(setvar "peditaccept" 1)
(setq i -1)
(while (setq ent (ssname sset (setq i (1+ i))))
(if (setq entpar (entget ent))
(if (setq dxf70 (assoc 70 entpar))
(if (/= 1 (cdr dxf70))
(vl-cmdf "pedit" ent "j" sset "" "")
)
(vl-cmdf "pedit" ent "j" sset "" "")
))
)
(vl-cmdf "undo" "e")
(princ)
)
(defun c:tt ()
(if (setq ss (ssget))(command "pedit" "m" ss "" "j" "0" ""))
(princ)
) ;代码纯手打,不容易,如果你有拷贝此副本,请保留此项.
;LISP 聚合程序.
;BY Urings.
;2016.11.22.
(defun |xxyyzz (un isd fuzz / an1 an2 cen crs dcr dseb ent eser esz l len n newc newo nsebs pls pt1 pt2 rad untp xx yy zz)
(defun xx (sex fuzz / are areis ari arr arris ars arsis dsn len n pid pidc pide pidis pidn pidnis pxs xsex)
(setq len (1- (length sex)))
(or
(minusp len)
(setq ars (vlax-make-safearray 2 (cons 0 len))
are (vlax-make-safearray 2 (cons 0 len))
arr (list ars are)
arsis (vlax-make-safearray 2 (cons 0 len))
areis (vlax-make-safearray 2 (cons 0 len))
arris (list arsis areis)
ari (vlax-make-safearray 2 (cons 0 len))
)
)
(setq pid -1)
(foreach n sex
(setq pid (1+ pid))
(setq pxs (cons (list (car (car n)) (cadr (car n)) pid 0) pxs))
(setq pxs (cons (list (car (cadr n)) (cadr (cadr n)) pid 1) pxs))
(vlax-safearray-put-element ars pid -1)
(vlax-safearray-put-element are pid -1)
(vlax-safearray-put-element arsis pid -1)
(vlax-safearray-put-element areis pid -1)
)
(vl-sort pxs (function (lambda (e1 e2)
(if (equal (car e1) (car e2) fuzz)
(if (equal (cadr e1) (cadr e2) fuzz)
(progn
(if (zerop (cadddr e1))
(progn
(vlax-safearray-put-element ars (caddr e1) (caddr e2))
(vlax-safearray-put-element arsis (caddr e1) (cadddr e2))
)
(progn
(vlax-safearray-put-element are (caddr e1) (caddr e2))
(vlax-safearray-put-element areis (caddr e1) (cadddr e2))
)
)
(if (zerop (cadddr e2))
(progn
(vlax-safearray-put-element ars (caddr e2) (caddr e1))
(vlax-safearray-put-element arsis (caddr e2) (cadddr e1))
)
(progn
(vlax-safearray-put-element are (caddr e2) (caddr e1))
(vlax-safearray-put-element areis (caddr e2) (cadddr e1))
)
)
t
)
(< (cadr e1) (cadr e2))
)
(< (car e1) (car e2))
)
)
)
)
(repeat (setq len (1+ len))
(and
(/= -1 (vlax-safearray-get-element ari (setq len (1- len))))
(progn
(setq pid len)
(setq pidis 0)
(setq pidc pid)
(setq pide (vlax-safearray-get-element are pid))
(setq dsn (list (list pid pidis)))
(while (and
(/= -1 pid)
(/= -1 pidis)
(/= -1 (setq pidn (vlax-safearray-get-element (nth pidis arr) pid)))
(/= -1 (setq pidnis (vlax-safearray-get-element (nth pidis arris) pid)))
(= pid (vlax-safearray-get-element (nth pidnis arr) pidn))
)
(vlax-safearray-put-element ars pid -1)
(vlax-safearray-put-element are pid -1)
(vlax-safearray-put-element ari pid -1)
(setq pid pidn)
(setq pidis (- 1 pidnis))
(setq dsn (cons (list pid pidis) dsn))
)
(vlax-safearray-put-element ars pid -1)
(vlax-safearray-put-element are pid -1)
(vlax-safearray-put-element ari pid -1)
(setq pid pidc)
(vlax-safearray-put-element are pid pide)
(setq pidis 1)
(setq dsn (reverse dsn))
(while (and
(/= -1 pid)
(/= -1 pidis)
(/= -1 (setq pidn (vlax-safearray-get-element (nth pidis arr) pid)))
(/= -1 (setq pidnis (vlax-safearray-get-element (nth pidis arris) pid)))
(= pid (vlax-safearray-get-element (nth pidnis arr) pidn))
)
(vlax-safearray-put-element ars pid -1)
(vlax-safearray-put-element are pid -1)
(vlax-safearray-put-element ari pid -1)
(setq dsn (cons (list pidn pidnis) dsn))
(setq pid pidn)
(setq pidis (- 1 pidnis))
)
(vlax-safearray-put-element ars pid -1)
(vlax-safearray-put-element are pid -1)
(vlax-safearray-put-element ari pid -1)
(setq dsn (cons (list pid pidis) dsn))
(setq pxs nil)
(foreach n dsn
(setq pxs (cons (cons (cadr n) (nth (car n) sex)) pxs))
)
(setq xsex (cons pxs xsex))
)
)
)
xsex
)
(defun yy (sex fuzz / len m n pl plbul plcs ple pler plis plos)
(foreach n sex
(setq pl nil)
(foreach m n
(setq plbul (cadddr m))
(or
(zerop (car m))
(setq plbul (- plbul))
)
(setq pl (cons (cons 42 plbul) (cons (cons 10 (nth (1+ (car m)) m)) pl)))
)
(setq plis 0)
(setq len (length n))
(and
(equal (cadr pl) (last pl) fuzz)
(setq plis 1
pl (cddr pl)
len (1- len)
)
)
(or
(and
(> len 1)
(setq ple (entmakex (append
(list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 len)
(cons 70 plis)
)
(reverse pl)
'((210 0. 0. 1.))
)
)
)
(if (zerop plis)
(setq plos (cons ple plos))
(setq plcs (cons ple plcs))
)
)
(setq pler (cons pl pler))
)
)
(list plcs plos pler)
)
(defun zz (crx / e es eser n)
(foreach n crx
(or
(and
(setq e (entmakex (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "ACDbCircle") (cons 10 (car n))
(cons 40 (cadr n)) '(210 0. 0. 1.)
)
)
)
(setq es (cons e es))
)
(setq eser (cons n eser))
)
)
(list es eser)
)
(setq untp (type un))
(cond
((= untp 'ename)
(setq l (list un))
)
((= untp 'list)
(setq l un)
)
((= untp 'pickset)
(repeat (setq len (sslength un))
(setq l (cons (ssname un (setq len (1- len))) l))
)
)
)
(foreach n l
(setq ent (entget n))
(setq untp (cdr (assoc 0 ent)))
(cond
((= untp "LINE")
(setq pt1 (cdr (assoc 10 ent)))
(setq pt2 (cdr (assoc 11 ent)))
(if (> (distance pt1 pt2) fuzz)
(setq dseb (cons (list pt1 pt2 0.0) dseb))
(setq esz (cons n esz))
)
)
((= untp "ARC")
(setq cen (cdr (assoc 10 ent)))
(setq rad (cdr (assoc 40 ent)))
(setq an1 (cdr (assoc 50 ent)))
(setq an2 (cdr (assoc 51 ent)))
(setq pt1 (polar cen an1 rad))
(setq pt2 (polar cen an2 rad))
(setq an1 (- an2 an1))
(and
(minusp an1)
(setq an1 (+ an1 6.283185307179586))
)
(if (> (distance pt1 pt2) fuzz)
(if (zerop (setq an2 (cos (setq an1 (/ an1 4.0)))))
(setq dseb (cons (list pt1 pt2 1.7e308) dseb))
(setq dseb (cons (list pt1 pt2 (/ (sin an1) an2)) dseb))
)
(if (and
(> rad fuzz)
(> an1 3.141592653589793)
)
(setq dcr (cons (list cen rad) dcr))
(setq esz (cons n esz))
)
)
)
((= untp "CIRCLE")
(setq cen (cdr (assoc 10 ent)))
(setq rad (cdr (assoc 40 ent)))
(if (> rad fuzz)
(setq dcr (cons (list cen rad) dcr))
(setq esz (cons n esz))
)
)
(t
(setq eser (cons n eser))
)
)
)
(foreach n (append eser esz)
(setq l (vl-remove n l))
)
;(princ (list dseb dcr l eser esz));debug
;(list dseb dcr l eser esz);1.(起点终点凸度)2.(圆心半径)3.(在容差内的图元)4.(不在容差内的图元)5.(相对fuzz零长度图元)
(setq nsebs (xx dseb fuzz))
(setq pls (yy nsebs fuzz));(list plcs plos pler);1.(闭合多段线)2.(不闭合多段线)3.(不能生成的多段线数据)
(setq crs (zz dcr));(list es eser);1.(圆)2.(不能生成的圆数据)
(and
isd
(foreach n l
(entdel n);删除原数据
)
)
(foreach n esz
(entdel n);删除相对零长度实体
)
(setq newc (append
(car pls)
(car crs)
)
)
(setq newo (cadr pls))
(list newc newo (caddr pls) (cadr crs)eser)
;1.(新闭合的实体)2.(未闭合的实体)3.(不能生成的多段线数据)4.(不能生成的圆数据)5.不能识别的实体
)
(vl-load-com)
;聚合测试
(defun c:eg (/ fuzz isd n rt ss)
(setq ss (ssget));只处理线段,圆弧,圆
(setq isd t);是否删除原数据
(setq fuzz 0.000001);相隔多远认为是相连的,曲线的长度或圆的半径小于此值将被当成0长度实体且被删除.
(nortime)
(setq rt (|xxyyzz ss isd fuzz))
(princ "\n*****共聚合实体*****\n")
(print (sslength ss))
(princ "\n*****新生成的闭合实体*****\n")
(print (length(car rt)))
(princ "\n*****新生成的打开实体*****\n")
(print (length(cadr rt)))
;(foreach n (cadr rt)
; (redraw n 3)
;)
(princ "\n*****不能生成的多段线*****\n")
(print (length(caddr rt)))
(princ "\n*****不能生成的圆*****\n")
(print (length(cadddr rt)))
(princ "\n*****未处理的实体(不是线段,圆弧或圆)*****\n")
(print (length(last rt)))
(princ "\n**********\n")
(gettime)
(setq ss nil)
(princ)
)
(defun nortime nil
(setvar "userr1" (getvar "tdusrtimer"))
(princ)
)
(defun gettime nil
(princ (strcat "\n用时:" (rtos (* (- (getvar "tdusrtimer") (getvar "userr1")) 86400) 2 3)"秒.\n"))
(princ)
)
页:
[1]