[弹指神通]：消除复线上多余顶点的程序(不是重复顶点)

舟自横

最近一个朋友由于工作原因需要这样一个程序:
取消复线上所有多余的点:
多余点的含义是:比如复线中有两点之间是线段连接或圆弧连接的
而在这两点之间还有一个顶点刚好在这两点之间的顶点或圆弧度上
此程序就是要消除这些点让复线任意两点之间不在有多余的顶点
[php]
(defun hy_mopline(pline / *vlhy-ActiveDocument* *vlhy-ModelSpace* paramlist okey rad1 base
                  ent bu1 bu2 ro objpline number i cenlist numberx u1 u2 p1 p2 dis rad
                  reent);;?耿絬
  (defun count(o num)
    (if (< o 0) (+ num o)
    o
    )
    )
  (defun countce(pa pb bulge / dis gongao mp centerp)
      (setq dis (distance pa pb))
      (setq gongao (abs (* (/ dis 2) bulge)));;?蔼
      (SETQ MP (MAPCAR '(LAMBDA (x y) (/ (+ x y) 2)) pa pb))
      (setq rad (/ (+ (expt gongao 2) (expt (/ dis 2) 2)) (* 2 gongao )));GET THE RADIUS
      (cond ((> 0 bulge)
                  (setq centerp (polar mp (- (angle pa pb) (* 0.5 pi)) (- rad gongao)))
             )
            ((< 0 bulge)
                 (setq centerp (polar mp (+ (angle pa pb) (* 0.5 pi)) (- rad gongao))))
                     
           )
  centerp
  )
  (setq *vlhy-ActiveDocument* (vla-Get-ActiveDocument (vlax-Get-Acad-Object)))
  (setq *vlhy-ModelSpace* (vla-Get-ModelSpace *vlhy-ActiveDocument*))
  (hy_delcfvetex pline 0.00001)
  (setq ent (entget pline))
  (setq objpline (vlax-ename->vla-object pline))
  (IF (and (= (vla-get-closed objpline) :vlax-FALSE)
           (equal (vlax-curve-getstartpoint objpline)
                  (vlax-curve-getendpoint objpline)
                  0.00001)
           )
    (progn
      (vla-put-closed objpline :vlax-true)
      (setq ent (entget pline))
      (setq reent (reverse ent))
      (setq ent (reverse
    (append (list (car reent)) (cdr (member (assoc 10 reent) reent)))
    ))
      (entmod ent)
    )
    )
  (setq number (length (massoc 10 ent)))
  (setq o 0 paramlist nil)
  (repeat number (setq paramlist (cons o paramlist) o (1+ o)))
  (setq okey t)
  (if (setq base (osnap (vlax-curve-getpointatparam objpline 0.5) "cen"))
    (progn (setq rad1 (distance base (vlax-curve-getpointatparam objpline 0.5)))
           (if (and (not (vl-some '(lambda(x) (not(equal base
                             (osnap (vlax-curve-getpointatparam objpline (+ x 0.5)) "cen")
                               0.00001)
                               )
                  ) (reverse (cdr paramlist))))
                   (= (vla-get-closed objpline) :vlax-true))
          (progn (vla-delete objpline)
                 (vla-addcircle *vlhy-ModelSpace* (vlax-3D-Point base) rad1)
                 (setq okey nil))
             )
      )
    )
  (if okey (progn
  (setq cenlist nil)
  (if (= (vla-get-closed objpline) :vlax-true) (setq numberx  number  i 0)
    (setq numberx (- number 2) i 1))
  (repeat numberx
    (cond ((and (/= 0 (setq bu1 (vla-getbulge objpline (count (1- i) number))))
                (/= 0 (setq bu2 (vla-getbulge objpline i)))
                (equal (setq ro (countce (vlax-curve-getpointatparam objpline (count (1- i) number))
                         (vlax-curve-getpointatparam objpline i) bu1))
                        (countce (vlax-curve-getpointatparam objpline i)
                         (vlax-curve-getpointatparam objpline (1+ i)) bu2)
                       0.00001)
                )
           (setq ent (vl-remove (list 10
                                       (car (vlax-curve-getpointatparam objpline i))
                                       (cadr (vlax-curve-getpointatparam objpline i))
                                       )
                       ent)
                cenlist (cons
                          (list
                            (vlax-curve-getpointatparam objpline (count (1- i) number))
                            ro
                            (if (minusp (vla-getbulge objpline i)) -1 1)
                            )
                            cenlist)
                 )
             )
          ((and (= 0 (vla-getbulge objpline (count (1- i) number)))
                (= 0 (vla-getbulge objpline i))
                (equal (angle (vlax-curve-getpointatparam objpline (count (1- i) number))
                          (vlax-curve-getpointatparam objpline i))
                   (angle (vlax-curve-getpointatparam objpline i)
                          (vlax-curve-getpointatparam objpline (1+ i))
                          )
                   0.00001)
                )
           (setq ent (vl-remove (list 10
                                       (car (vlax-curve-getpointatparam objpline i))
                                       (cadr (vlax-curve-getpointatparam objpline i))
                                       )
                       ent))
                       )
          )
    (setq i (1+ i))
    )
  (setq cenlist (reverse cenlist))
  (entmod ent)
  (if cenlist
  (foreach item cenlist
    (if (and (setq u1 (vlax-curve-getparamatpoint objpline (car item)))
             (equal (fix u1) u1 0.000001))
      (progn
      (setq u2 (+ u1 1))
      (setq p1 (vlax-curve-getpointatparam objpline u1))
      (setq p2 (vlax-curve-getpointatparam objpline u2))
      (setq dis (distance p1 p2))(setq rad (distance (cadr item) p1))
      (cond ((and (= 1 (caddr item))
               (or (and (> (- (angle (cadr item) p2) (angle (cadr item) p1)) 0)
                        (< (- (angle (cadr item) p2) (angle (cadr item) p1)) pi)
                        )
                   (and (< (- (angle (cadr item) p2) (angle (cadr item) p1)) (- 0 pi))
                        (> (- (angle (cadr item) p2) (angle (cadr item) p1)) (- 0 pi pi))
                        )
                   )
               )
             (setq bulge (/ (- rad (expt (- (expt rad 2) (expt (* dis 0.5) 2)) 0.5)) (* dis 0.5)))
             )
            ((and (= 1 (caddr item))
               (or (and (> (- (angle (cadr item) p2) (angle (cadr item) p1)) pi)
                        (< (- (angle (cadr item) p2) (angle (cadr item) p1)) (* 2 pi))
                        )
                   (and (< (- (angle (cadr item) p2) (angle (cadr item) p1)) 0)
                        (> (- (angle (cadr item) p2) (angle (cadr item) p1)) (- 0 pi))
                        )
                   )
               )
             (setq bulge (/ (+ rad (expt (- (expt rad 2) (expt (* dis 0.5) 2)) 0.5)) (* dis 0.5)))
             )
            ((and (= -1 (caddr item))
               (or (and (> (- (angle (cadr item) p2) (angle (cadr item) p1)) 0)
                        (< (- (angle (cadr item) p2) (angle (cadr item) p1)) pi)
                        )
                   (and (< (- (angle (cadr item) p2) (angle (cadr item) p1)) (- 0 pi))
                        (> (- (angle (cadr item) p2) (angle (cadr item) p1)) (- 0 pi pi))
                        )
                   )
               )
             (setq bulge (/ (+ rad (expt (- (expt rad 2) (expt (* dis 0.5) 2)) 0.5)) (* dis 0.5)))
             )
            ((and (= -1 (caddr item))
               (or (and (> (- (angle (cadr item) p2) (angle (cadr item) p1)) pi)
                        (< (- (angle (cadr item) p2) (angle (cadr item) p1)) (* 2 pi))
                        )
                   (and (< (- (angle (cadr item) p2) (angle (cadr item) p1)) 0)
                        (> (- (angle (cadr item) p2) (angle (cadr item) p1)) (- 0 pi))
                        )
                   )
               )
             (setq bulge (/ (- rad (expt (- (expt rad 2) (expt (* dis 0.5) 2)) 0.5)) (* dis 0.5)))
             )
            )
      (vla-setbulge objpline u1 (* bulge (caddr item)))
      )
      )
    )
    )
      )
    )
  )
(defun massoc (key alist / x nlist)
  (foreach x alist
    (if (eq key (car x))
      (setq nlist (cons (cdr x) nlist))
      )
    )
  (reverse nlist))
(defun hy_delcfvetex (e preci  / a a1 b b1 c c1 en j n new p p1 key)
  (setq en (entget e))
  (while (setq n (car en))
    (if        (= (car n) 90)
      (setq j (cdr n))
    )
    (if        (= (car n) 10)
      (progn
        (mapcar 'set '(p a b c) en)
        (setq en  (cddddr en)
              key t
        ) ;_key??dxf10
        (if (equal p1 p preci)
          (setq j (1- j))
          (if p1
            (setq new (append new (list p1 a1 b1 c1)))
          )
        )
        (mapcar 'set '(p1 a1 b1 c1) (list p a b c))
      ) ;_progn
      (progn (if key
               (setq new (append new (list p1 a1 b1 c1))
                     key nil
               ) ;_dxf10Ч?.
             )
             (setq new (append new (list n))
                   en  (cdr en)
             )
      )
    ) ;_if
  ) ;_while
  (entmod (subst (cons 90 j) (assoc 90 new) new))
)
[/php]
测试
(defun c:tt() (hy_mopline (car(entsel))))

狂刀

函数不全，舟兄，你的程序测试起来咋这麻烦呢？

舟自横

不好意思..呵呵..漏了一个..已经编辑过..请重新测试..

dezhang

楼主，你真是强人呀！顺便问个菜鸟级问题，objectdcl与vlisp有什么不同？

aeo

hy_delcfvetex ,这一段基本是我写的:)

举个例子：A到B,线宽是从0到100,B到C,一直是100,那B点去掉吗?
AB,CD都是圆弧呢?
都为同圆心的圆弧呢?
AB线宽从0到50,BC从50到101,又是什么情况呢?

狂刀

我是这么觉得，有等宽度的多义线，才进行顶点净化；有宽度变换的多义线片断，通常情况是有一定意义的（比如说画箭头），因此建议过滤掉有宽度变换的“段”，不必进行净化处理。

舟自横

最初由 dezhang 发布
[B]楼主，你真是强人呀！顺便问个菜鸟级问题，objectdcl与vlisp有什么不同？ [/B]

objectdcl与vlisp 的区别..这个问题你倒难倒我了.
我决的OBJECTDCL的原理应该和VLISP差不多吧..都是工具
OBJECTDCL对对话框的部分做了强化使对话框不用写而是用画的..这点应该是仿照VB的..应该说他是VLISP和VB的结合体..但是在使用的过程中(3.0版本)我却发现了不少问题..觉得他还是不很完美
期待有更完美的版本出现
另程序中是用了AEO斑竹的一段程序并表示感谢...
狂刀兄所说的有宽度段不处理.应该可以实现..不过我工作中一般不遇到宽度复线..所以在我的程序中一般不予考虑..如果刀兄有兴趣..等过几天有时间我修正一下...
另回AEO斑竹我程序中并未对线宽做处理..我程序中净化的是多余顶点
A到B段和B到C段都是直线段并且斜率一样那程序就会过滤掉B点
圆弧段也一样可以过滤..如果复线刚好是组成一个整圆的话程序就重新画一个半径一样大小的圆并删除原来的复线..

eachy

假如Pline中间段有一个“园”，也是顶点重合，但中间那个点是不能去掉的。

狂刀

ｅａ的意思是说不应该去掉吧？

舟自横

最初由 eachy 发布
[B]假如Pline中间段有一个“园”，也是顶点重合，但中间那个点是不能去掉的。 [/B]

那种情况好象是不可以..
那可是极度状况..加判断吧...呵呵..好象越来越复杂了..

WHGF

这段程序对于处理SPLINE转成PLINE后节点非常多的线段很实用。修改后可做线段抽稀用。
下来备用!

77lsy

怎么用啊是不是加载后输TT?

它山之石

图中的点3未能删除。
另外有些多义线，需镜像后才能删除多余点

舟自横

程序是逐段判斷的。。所以對石兄的那種情況是不適用的。。
"另外有些多义线，需镜像后才能删除多余点" 可否附上例子以便于修正。。。

它山之石

如图