求个多段线去无用点的函数，一直写不好
求个多段线去无用点的函数，多段线均为直线段，无弧段要求如下：
1.端点中，共直线去掉中间点，重合的点去掉；
2.闭合的多段线中，起始点重合的，去掉一个点；
3.闭合线时，起始点可能和其它点共线，也要考虑
本帖最后由 hb198075 于 2018-2-5 15:38 编辑
以前有做过类似的程序，看看是否你想要的效果。先上图
;;;删除PL线上点程序 制作：HuangBang
(VL-LOAD-COM)
(defun c:dp1 (/ ss )
(if(setq ss (dp-getfirst))
(dp-delPoint ss)
(progn
(if (cadr (ssgetfirst))
(command)
)
(prompt "\n请选择多段线")
(if (setq ss (ssget ":E:S" '((0 . "LWPOLYLINE"))))
(progn
(dp-delPoint ss)
)
)
)
)
(princ)
)
;;;删除重复点程序
(defun c:dpr1 (/ ss na n ent cnt n_close)
(setq cnt 0)
(if(setq ss (ssget '((0 . "LWPOLYLINE"))))
(progn
(setq n 0)
(repeat(sslength ss)
(setqna(ssname ss n)
ent (entget na)
n (1+ n)
)
(setq cnt(+ cnt (DP-DELREP ent)))
)
(prompt (strcat "\n一共清除" (itoa cnt) "个重复点"))
)
)
(princ)
)
(defun dp-getfirst (/ slst ss na ent e0 rel)
(setqslst (ssgetfirst)
ss (cadr slst)
)
(if ss
(if(= (sslength ss) 1)
(progn
(setq na(ssname ss 0)
ent (entget na)
e0(cdr (assoc 0 ent))
)
(if (wcmatch e0 "LWPOLYLINE")
(setq rel ss)
)
)
)
)
rel
)
(defun dp-delPoint (ss / p0 p1 ent is unlst cnt)
(SSSETFIRST nil ss)
(setq m_setfirst t)
(setq ent (entget (ssname ss 0)))
(while (null is)
(initget "R U")
(setq p0 (getpoint "\n指定删除框的第一点[删除重复点(R)/放弃(U)]:"))
(cond
((= (type p0) 'list)
(setq p1 (GETCORNER p0 "\n指定对角点:"))
(if p1
(setq unlst (cons ent unlst)
ent (dp-delInRec ent (trans p0 1 0) (trans p1 1 0))
)
)
)
((= p0 "") (setq is t))
((null p0) (setq is t))
((= p0 "U")
(if unlst
(progn
(setq ent(car unlst))
(entmod (car unlst))
(setq unlst (cdr unlst))
)
(princ "无操作可以返回!")
)
)
((= p0 "R")
(setq cnt (dp-delReP ent))
(prompt (strcat "\n清除" (itoa cnt) "个重复点"))
(setq is t)
)
)
)
(SSSETFIRST nil nil)
(setq m_setfirst nil)
)
;;;判断点是否在矩形范围
(defun dp-isInRec (pt p0 p1 / xx xy dx dy)
(setqpt (trans pt 0 1)
p0 (trans p0 0 1)
p1 (trans p1 0 1)
)
(if (< (car p0) (car p1))
(setq xx (car p0)
dx (car p1)
)
(setq xx (car p1)
dx (car p0)
)
)
(if (< (cadr p0) (cadr p1))
(setq xy (cadr p0)
dy (cadr p1)
)
(setq xy (cadr p1)
dy (cadr p0)
)
)
(and (<= xx (car pt) dx)
(<= xy (cadr pt) dy)
)
)
;;;删除矩形内的顶点
(defun dp-delInRec (ent p0 p1 / itm plst)
(setq plst (HB_GETENTCOUNT ent 10))
(foreach itm plst
(if(dp-isInRec itm p0 p1)
(setq ent (DP-DELPT ent itm nil))
)
)
(entmod ent)
)
;;;判断顶点是否在直线上
(defun dp-ptOnLine (pt p1 p2 /)
(equal (+ (DISTANCE pt p1) (DISTANCE pt p2))
(DISTANCE p1 p2)
(* dp_wc 0.00001);0.0000001
)
;;; (equal (abs (- (DISTANCE pt p1) (DISTANCE pt p2)))
;;; (DISTANCE p1 p2)
;;; 0.0000001
;;; )
)
(defun dp-delClosed (ent plst is / rel len p1 p2 p0 )
(setq len (length plst))
(setqp0 (nth 0 plst)
p1 (nth 1 plst)
)
(if is
(if (equal (nth 0 plst) (nth (1- len) plst))
(setq p2 (nth (- len 2) plst))
(setq p2 (nth (- len 1) plst))
)
(setq p2 (nth (- len 2) plst))
)
(if (DP-PTONLINE p0 p1 p2)
(setq rel(DP-DELPT ent (nth 0 plst) "closed")
count(1+ count)
)
(setq rel ent)
)
rel
)
;;;删除重复的点
(defun dp-delRep
(ent / plst len p0 p1 p2 count dpn isclose obj tmp cln n)
(setqplst(HB_GETENTCOUNT ent 10)
obj(vlax-ename->vla-object (cdr (assoc -1 ent)))
isclose(vla-get-closed obj)
len(length plst)
dpn0
)
(setqn 1
count 0
)
;;;循环删除同一直线上的顶点
(while (setq p2 (nth (1+ n) plst))
(setq p0 (nth (1- n) plst)
p1 (nth n plst)
)
(if(dp-ptOnLine p1 p0 p2)
(setq ent (dp-delPt ent p1 (- n dpn))
count (1+ count)
dpn (1+ dpn)
)
)
(if (or (equal p0 p1)(equal p1 p2))
(setq n (1+ n))
)
(setq n (1+ n))
)
;;;检验是否为闭合多段线
(setq plst (HB_GETENTCOUNT ent 10)
len (length plst)
)
(if (= isclose :vlax-false)
(if(equal (nth 0 plst) (nth (1- len) plst))
(progn
(if (null n_close)
(progn
(setq m_redraw (cdr (assoc -1 ent)))
(redraw m_redraw 3)
(initget "Yes No AYes ANo")
(setq tmp
(getkword
"\n该多段线首尾相连，但并未闭合，是否设置为闭合状态<Yes>:"
)
)
(cond
((null tmp) (setq tmp "Yes"))
((= tmp "AYes") (setq n_close "YES"))
((= tmp "ANo") (setq n_close "NO"))
)
(setq m_redraw nil)
)
)
(if (or(= n_close "YES")
(= tmp "Yes")
)
(progn
(setq ent (DP-DELCLOSED ent plst nil)
cln t
)
(vla-put-closed obj :vlax-true)
)
)
)
)
(setq ent (DP-DELCLOSED ent plst t))
)
(entmod ent)
(if cln
(vla-put-closed obj :vlax-true)
)
count
)
;;;删点操作
(defun dp-delPt(ent pt cnt / itm isdel rel m len)
(setq m 0)
(setq len (length (HB_GETENTCOUNT ent 10)))
(foreach itm ent
(if(= (car itm) 10)
(progn
(if (equal (cdr itm) pt)
(if cnt
(cond
((= cnt m)
(setq isdel t)
)
((= cnt "end")
(if (= m (- len 1))
(setq isdel t)
(setq rel (cons itm rel)
isdel nil
)
)
)
((= cnt "start")
(if (= m 0)
(setq isdel t)
(setq rel (cons itm rel)
isdel nil
)
)
)
((= cnt "closed")
(if (or (= m 0)
(= m (- len 1))
)
(setq isdel t)
(setq rel (cons itm rel)
isdel nil
)
)
)
(t
(setq rel (cons itm rel)
isdel nil
)
)
)
(setq isdel t)
)
(setqrel (cons itm rel)
isdel nil
)
)
(setq m (1+ m))
)
(if isdel
nil
(setq rel (cons itm rel))
)
)
)
(reverse rel)
)
(defun hb_getEntCount (ent ename / tmp n rel cns)
(foreach cns ent
(if(= (car cns) ename)
(progn
(setq tmp (cdr cns))
(setq rel (cons tmp rel))
)
)
)
(reverse rel)
)
(princ "\n*****多段线顶点删除程序，制作hb198075，命令名：DP1,DPR1*****")
页:
[1]