求高手帮忙完成多段线随意加关键点的程序

lzr_00

Gu_xl版主程序很好

清风明月名字

谢谢楼主，学习一下

king3d

能改成一个命令多次加点就好了。

raimo

king3d 发表于 2012-5-31 14:47
能改成一个命令多次加点就好了。

楼上的没有试过吗？ 本来就可以多次加点的

woodhhm

不错啊！谢谢！

xuexicad1960

看看G大侠的程序

半听可乐

个人搜集的：PL1 删除多义线顶点
                     PL2 增加除多义线顶点

;★PL2 多义线添加顶点
(defun C:PL2 (/ BULGE ENAME ENT PT)
  (if (and (setq ENT (entsel))
    (setq ENAME (car ENT))
    (setq PT (vlax-curve-getclosestpointto ENAME (cadr ENT)))
    (setq BULGE 0)
      )
    (ADD_VERTEX ENAME PT BULGE)
  )
)


(defun Add_Vertex (ename pt bulge / obj n dm d1 d2 pcen v plist)
  (setq obj (vlax-ename->vla-object ename))
  (if (vlax-curve-getParamAtPoint obj pt)
    (progn
  (setq n (fix (vlax-curve-getParamAtPoint obj pt)))
  (setq dm (vlax-curve-getDistAtPoint obj pt))
  (setq d1 (vlax-curve-getDistAtParam obj n))
  (setq d2 (vlax-curve-getDistAtParam obj (1+ n)))
  (setq v (vlax-curve-getsecondderiv obj n))
  (if (zerop (vla-getbulge obj n))
    (vla-AddVertex obj (1+ n) (ax:2DPoint pt))
    (progn
      (if (> (vla-getbulge obj n) 0)
    (setq pcen (mapcar '+ (vlax-safearray->list (vlax-variant-value (vla-get-Coordinate obj n))) v))
    (setq pcen (mapcar '- (vlax-safearray->list (vlax-variant-value (vla-get-Coordinate obj n))) v))
      )
      (setq ang2m
        (* 0.25
           (- (angle pcen (vlax-safearray->list (vlax-variant-value(vla-get-Coordinate obj (1+ n)))))
          (angle pcen pt)
           )
        )
        angm1
        (* 0.25
           (- (angle pcen pt)
          (angle pcen (vlax-safearray->list (vlax-variant-value(vla-get-Coordinate obj n))))
           )
        )
      )
      (vla-AddVertex obj (1+ n) (ax:2DPoint pt))
      (vla-SetBulge obj n (/ (sin angm1) (cos angm1)))
      (vla-SetBulge obj (1+ n) (/ (sin ang2m) (cos ang2m)))
    )
  )
  )
  (progn
    (setq plist    (vlax-safearray->list
          (vlax-variant-value
            (vla-get-coordinates obj)
          )
        )
    )
    (vla-AddVertex obj (/ (length plist) 2) (ax:2DPoint pt))
    (vla-SetBulge obj (1- (/ (length plist) 2)) bulge)
    )
  )
  (vla-update obj)
  (princ)
)

(defun ax:2DPoint (pt)
  (vlax-make-variant
    (vlax-safearray-fill
      (vlax-make-safearray vlax-vbdouble '(0 . 1))
      (list (car pt) (cadr pt))
    )
  )
)



;★PL1  多义线删除顶点
(defun c:PL1 ()
(setq p (getpoint "\nPick Point:"))
(setq ents (entget (ssname (ssget p) 0)))
(setq lst (member (list 10 (car p)(cadr p)) ents))
(foreach i (list (assoc 10 lst)(assoc 40 lst)(assoc 41 lst)(assoc 42 lst))
(setq ents (vl-remove i ents))
)
(entmod ents)
)

半听可乐

Gu_xl 发表于 2011-9-21 22:59
稍加改进，连续加点，并且有夹点显示，可以及时看见所加点！
**** 本内容被作者隐藏 ****

G神，这程序经过测试发现有个bug：如果选择增加点不在线上，PL线则会被断开

lidaxiu

e2002

加上动态就完美了