|
|
;;;------------------------------------------------------------------------;;;
;;; 归范化多义线 ;;;
;;; 1. 消除折环 ;;;
;;; 2. 消除冗余结点 ;;;
;;;------------------------------------------------------------------------;;; ;;;
(vl-load-com)
(defun c:test ( / old_osmd sset len i item lst coords name ssp txtobj
retlst ptcur pt j pti)
(setq old_osmd (getvar "osmode"))
(setvar "osmode" 0)
(vla-ZoomExtents (vlax-get-acad-object))
(setq sset (ssget "x" (list
(cons -4 "")
(cons -4 "")
(cons -4 "or>")
)
))
(setq len (sslength sset))
(setq i 0)
(repeat len
(setq ename (ssname sset i))
(setq item (vlax-ename->vla-object ename))
;取得多义线坐标
(setq lst (vlax-safearray->list
(vlax-variant-value
(vlax-get-property item 'Coordinates))
)
)
(setq coords nil)
(if (= (vlax-get-property item 'ObjectName) "AcDb2dPolyline")
(progn
(while lst
(if (= coords nil)
(setq coords (list (list (nth 0 lst) (nth 1 lst))) )
(setq coords (append coords (list (list (nth 0 lst) (nth 1 lst)))))
)
(setq lst (cdr (cdr (cdr lst))))
)
)
)
(if (= (vlax-get-property item 'ObjectName) "AcDbPolyline")
(progn
(while lst
(if (= coords nil)
(setq coords (list (list (nth 0 lst) (nth 1 lst))) )
(setq coords (append coords (list (list (nth 0 lst) (nth 1 lst)))))
)
(setq lst (cdr (cdr lst)))
)
)
)
;处理坐标coords
(setq lastpt (car (reverse coords))) ;提取最后一个结点坐标
(setq coords (reverse (cdr (reverse coords)))) ;从coords中删除最后一个结点坐标
;构建新的坐标表
(setq retlst nil)
(while coords
(if (= retlst nil)
(setq retlst (list (nth 0 coords) )) ;提取第一个点
(progn
(setq ptcur (nth 0 coords))
;判断pt是否已经在retlst中,若为F,加入到retlst
(setq exist nil j 0)
(while (setq pt (nth j retlst))
;ptcur与pt和lastpt比较
(if (or (and (= (nth 0 ptcur) (nth 0 pt)) (= (nth 1 ptcur) (nth 1 pt)))
(and (= (nth 0 ptcur) (nth 0 lastpt)) (= (nth 1 ptcur) (nth 1 lastpt)))
)
(setq exist t)
);
(setq j (+ j 1))
);while
;
(if (not exist)
(setq retlst (append retlst (list ptcur)))
)
);progn
);if
(setq coords (cdr coords))
)
(setq retlst (append retlst (list lastpt)))
;判断是否封闭
(setq closed nil)
(vlax-dump-object item t)
(if (vlax-property-available-p item 'Closed)
(setq closed (vlax-get-property item 'Closed))
)
;绘新多义线
(command "pline")
(foreach pti retlst (command pti))
(if (= closed :vlax-true)
(command "C" "")
(command "" "")
)
(command)
;属性匹配
(command "matchprop" ename (entlast) "")
;删除线对象
(vlax-invoke-method item 'Delete)
(setq i (+ i 1))
(grtext -1 (itoa i))
);repeat
(setvar "osmode" old_osmd)
(grtext -1 "OK")
(princ "\nOK!")
(alert "OK!")
(grtext -1 "")
(princ)
);defun
归范化多义线
本帖以下内容被隐藏保护；需要你回复后，才能看到！ 游客，如果您要查看本帖隐藏内容请 回复 |
|
置顶卡
