求个多段线去无用点的函数，一直写不好

myjping · 发表于 2018-2-2 16:56

求个多段线去无用点的函数，多段线均为直线段，无弧段
要求如下：
1.端点中，共直线去掉中间点，重合的点去掉；
2.闭合的多段线中，起始点重合的，去掉一个点；
3.闭合线时，起始点可能和其它点共线，也要考虑

hb198075 · 发表于 2018-2-5 15:31

本帖最后由 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)
(setq na (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)
(setq slst (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)
(setq pt (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))
(setq p0 (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)
(setq plst (HB_GETENTCOUNT ent 10)
obj (vlax-ename->vla-object (cdr (assoc -1 ent)))
isclose (vla-get-closed obj)
len (length plst)
dpn 0
)
(setq n 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/No/AllYes(AY)/AllNo(AN)]<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)
)
(setq rel (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*****")

;;;删除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) 
    (setq  na  (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) 
  (setq  slst (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) 
  (setq  pt (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)) 
  (setq  p0 (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) 
  (setq  plst  (HB_GETENTCOUNT ent 10) 
  obj  (vlax-ename->vla-object (cdr (assoc -1 ent))) 
  isclose  (vla-get-closed obj) 
  len  (length plst) 
  dpn  0 
  ) 
  (setq  n 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/No/AllYes(AY)/AllNo(AN)]<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) 
    ) 
    (setq  rel   (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*****")

账号		自动登录	找回密码
密码			注册

[函数] 求个多段线去无用点的函数，一直写不好

本帖子中包含更多资源