网上下的这个程序不能用,如何改动呢?

zfsaaa

网上下的这个程序不能用,如何改动呢?

;;;删除线上点;;;;
(defun c:delpoint (/ ensel ename object point width points new)
  (if (setq ensel (entsel "\n请选择一根线:"))
    (progn
      (setvar "cmdecho" 0)
      (command "undo" "g")
      (setq ename (car ensel))
      (setq object (vlax-ename->vla-object ename))
      (if (= (vla-get-entityname object) "AcDbPolyline")
 (while (progn (setvar "osmode" 1) (setq point (getpoint "\n请选择将要删除的点:")))
   (setq point (list (car point) (cadr point)))
   (setq width (car (vla-getWidth object 0 'StartWidth, 'EndWidth)))
   (setq points (poly_pts (vla-get-coordinates object)))
   (if (setq new (delpt))
     (progn (vla-put-coordinates object new) (command "pedit" ename "w" width ""))
     (print "只有两个点已不能再删除了!")
   )
 )
 (princ "\n这个程序只支持LWPOLYLINE!")
      )
      (vlax-release-object object)
      (command "undo" "e")
      (prin1)
    )
  )
)
(defun delpt (/ m n del return pt)
  (setq m (length points))
  (setq n 0)
  (repeat m
    (setq pt (nth n points)
   n  (1+ n)
    )
    (if del
      (setq return (append return pt))
      (if (equal pt point)
 (setq del t)
 (setq return (append return pt))
      )
    )
  )
  (if (> (length return) 3)
    return
  )
)

 

fansmax

缺少了子函数，我重写了子函数，你试试。

;;;删除线上点;;;;
(defun c:delpoint (/ ensel ename object point width points new)
  (if (setq ensel (entsel "\n请选择一根线:"))
    (progn
      (setvar "cmdecho" 0)
      (command "undo" "g")
      (setq ename (car ensel))
      (setq object (vlax-ename->vla-object ename))
      (if (= (vla-get-ObjectName object) "AcDbPolyline")
 (while (progn (setvar "osmode" 1) (setq point (getpoint "\n请选择将要删除的点:")))
   (setq point (list (car point) (cadr point)))
   (setq width (car (vla-getWidth object 0 'StartWidth, 'EndWidth)))
   (setq points (poly_pts (vla-get-coordinates object)))
   (if (setq new (delpt))
     (progn (vla-put-coordinates object new) (command "pedit" ename "w" width))
     (print "只有两个点已不能再删除了!")
   )
 )
 (princ "\n这个程序只支持LWPOLYLINE!")
      )
      (vlax-release-object object)
      (command "undo" "e")
      (prin1)
    )
  )
)

(defun delpt (/ m n del return pt pnts)
  (setq m (length points))
  (setq n 0)
  (repeat m
    (setq pt (nth n points)
   n  (1+ n)
    )
    (if del
      (setq return (append return pt))
      (if (equal pt point)
 (setq del t)
 (setq return (append return pt))
      )
    )
  )
  (if (> (length return) 3)
    (progn
      (setq pnts (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length return)))))
      (vlax-safearray-fill pnts return)
      pnts
    )
  )
)

(defun poly_pts (num / lst i% lst_n)
  (setq lst (vlax-safearray->list (variant-value num)))
  (setq i% 0)
  (repeat (/ (length lst) 2)
    (setq lst_n (cons (list (nth i% lst) (nth (1+ i%) lst)) lst_n))
    (setq i% (+ 2 i%))
  )
  (setq lst_n (reverse lst_n))
)

zfsaaa

谢谢楼上大侠，这个程序基本可用，但遇到圆弧还有缺陷，对圆弧和直接组成的多边形，删点时就乱了套，不知谁能完善，谢谢！

fansmax

呵呵，个人认为对于复合线中连续弧段的节点删除要实现理想效果是不可能的，因为可能出现有几种解，程序无法知道你具体需要哪一种解法。

例如：把连续弧段中的某个节点删除了，哪是该用一段直线作修补？还是作正方向弧作修补？还是用反方向弧作修补？

按以上的逻辑去思考是无法得出具种情况下的正解。

zfsaaa

fansmax发表于2010-4-19 11:44:00呵呵，个人认为对于复合线中连续弧段的节点删除要实现理想效果是不可能的，因为可能出现有几种解，程序无法知道你具体需要哪一种解法。例如：把连续弧段中的某个节点删除了，哪是该用一段直线作

谢谢!我还真没想那么多