[讨论]：删除多义线顶点的程序收集

陌生人 · 发表于 2004-5-16 16:49:41

对啊，lwpolyline和pl的安全数组中的元素数目是不同的,转为表后：
一个是（p1x p1y p2x p2y p3x p3y ....）
一个是（p1x p1y p1z p2x p2y p2z p3x p3y p3z ....）
你需先判断是那一种。

xxming · 发表于 2004-5-17 09:50:45

陌生人：你的增加、删除程序好象不能用啊，能否修改

陌生人 · 发表于 2004-5-17 13:58:25

哦？说说，有什么提示？
我这个贴的只管删除顶点，不管增加的

xxming · 发表于 2004-5-17 14:50:23

那好啊，你能编个增加和删除多义线顶点的程序吗？

陌生人 · 发表于 2004-5-17 17:27:39

你先回答怎么不能用了？有什么错误提示？有的话贴出来

xxming · 发表于 2004-5-18 11:01:00

各位：谁能编个个增加和删除多义线顶点的程序？？

XDSoft · 发表于 2004-5-18 12:30:07

最初由 xxming 发布
[B]各位：谁能编个个增加和删除多义线顶点的程序？？ [/B]

晓东工具箱里面，有这个程序。
用了XDRX API，你可以参考下。

[php]
;|
命令：poly_add_vertex
功能：给选择的POLYLINE段加入一个顶点

说明：程序配合XDRX_API使用，朋友们可以把这个LISP拷贝到“晓东工具箱”的安装的
 LISP目录，自己加入到菜单里面就可以非常方便的使用了。
 关于程序的建议请到“晓东CAD空间-编程申请”论坛
 http://www.xdcad.net/forum留言

|;
(defun $get_vertex_index (e pt / v_num i tf)
 (xdrx_setenttodb e)
 (if (= "POLYLINE" (xdrx_getentdxf 0))
(xdrx_polyline_ConvertFrom e)
 )
 (setq v_num (xdrx_polyline_numVerts e)
i -1
 )
 (setq tf t)
 (while (and
 tf
 (" '
 ((0 . "*polyline"))
)
)
(setq pt (getpoint "\n请点取要加入的顶点位置<退出>:"))

 )
(progn
 (setq pj (trans (cadr e) 1 0)
 pj (osnap pj "nea")
 )
 (setq i ($get_vertex_index (car e) pj))
 (xdrx_polyline_addVertexAt (car e) (1+ i) pt)
)
 )
 (princ)
)
;|
命令：poly_remove_vertex
功能：删除选择的POLYLINE的一个顶点
说明：程序配合XDRX_API build 20428＋版本使用，朋友们可以把这个LISP拷贝到“晓东工具箱”的安装的
 LISP目录，自己加入到菜单里面就可以非常方便的使用了。
 关于程序的建议请到“晓东CAD空间-编程申请”论坛
 http://www.xdcad.net/forum留言
|;
(defun c:poly_remove_vertex ()
 (xdrx_begin )
 (xdrx_sysvar_push "pickbox" "aperture")
 (setvar "pickbox" 5)
 (setvar "aperture" 5)
 (if (setq e (xdrx_entsel "\n请点取要去掉的多义线上的顶点<退出>" '
 ((0 . "*polyline"))
 )
 )
(progn
 (setq pj (trans (cadr e) 1 0)
 pj (osnap pj "int,end")
 )
 (setq i ($get_vertex_index (car e) pj))
 (xdrx_polyline_removeVertexAt (car e) (1+ i))
)
 )
 (xdrx_sysvar_pop)
 (xdrx_end)
 (princ)
)
[/php]

lsjjm · 发表于 2004-5-18 13:28:55

最初由 xxming 发布
[B]各位：谁能编个个增加和删除多义线顶点的程序？？ [/B]

增加多义线顶点
(defun c:test()
  (vl-load-com)
  (setq ent (entsel "Select Pline:"))
  (setq p (cadr ent)
   obj (vlax-ename->vla-object (car ent))
   pp (vlax-curve-getclosestpointto obj (trans p 1 0))
      n (fix (vlax-curve-getparamatpoint obj pp))
   pn (getpoint "\nPick a Point: ")
   pn (list (car pn)(cadr pn))
   newv (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble '(0 . 1)) pn))
  (vla-addvertex obj (1+ n) newv)
)

删除多义线顶点
(defun c:test ()
  (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)
)

陌生人 · 发表于 2004-5-18 14:49:06

(foreach i (list (assoc 10 lst)(assoc 40 lst)(assoc 41 lst)(assoc 42 lst))
(setq ents (vl-remove i ents))
42 相同的都会被喀嚓掉？

aeo · 发表于 2004-5-18 23:24:21

最初由 netbee 发布
[B]
我用
[code]
(setq obj1(vlax-ename->vla-object (car (entsel)))
vpoint(vlax-3d-point (getpoint))
)
... [/B]

Lwpolyline 是2d点.

lihb · 发表于 2004-10-28 20:40:56

这点删点和增点只能对LWPOLYLINE线.
哪个有能对2dpolyline和lwpolyline都能增点和删点程序．
能否共享一下．

还要补充一点，能不能把那个增点的程充做成动态效果．就是那点跟随鼠标动．
我正在学习中．做成那样就更把这个程序完美化了．

xxxyzxx · 发表于 2004-11-20 21:43:47

晕，程序过于复杂（因为LISP行太少，需要太高深的技巧），总的来说，思路开阔，值得学习！

netbee · 发表于 2005-2-14 20:09:51

前面的程序都会将所有经过该点的删除，不管是不是你想删除的。
我改了一下，但程序也就大了。

(defun NB_PL_DelPoint (/ obj1 obj p pt pts ptl i j narray)
(setq obj1 (entsel "\n选择对象：")
p (cadr obj1)
obj (vlax-ename->vla-object (car obj1))
p (vlax-curve-getclosestpointto OBJ (trans (cadr obj1) 1 0))
p (fix (+ 0.5 (vlax-curve-getparamatpoint OBJ p))) ;_拾取点在多段线中的位置
Pt (vlax-safearray->list
(vlax-variant-value
(vla-get-coordinate obj p)
)
) ;_返回第P个点的坐标
)
(setq pts (vlax-safearray->list
(variant-value (vla-get-coordinates obj))
)
)
(setq i 0
j (* 2 p)
)
;;将表中第P个点开始相同的点删除
;;
;;将第P个点前的所有点复制到ptl
(while (< i j)
(setq ptl (append ptl (list (car pts) (cadr pts)))
pts (cddr pts)
i (+ i 2)
)
)
;;删除P点及其后相同的点
(while (and (= (car pt) (car pts))
(= (cadr pt) (cadr pts))
)
(setq pts (cddr pts))
)
;;将其余所有点复制到ptl
(setq ptl (append ptl pts))
(if (>= (length ptl) 4)
(progn (setq narray (vlax-make-safearray
vlax-vbDouble
(cons 0 (1- (length ptl)))
)
)
(vla-put-coordinates obj (vlax-safearray-fill narray ptl))
)
)
)

(defun NB_PL_DelPoint (/ obj1 obj p pt pts ptl  i j narray) 
  (setq        obj1 (entsel "\n选择对象：") 
        p    (cadr obj1) 
        obj  (vlax-ename->vla-object (car obj1)) 
        p    (vlax-curve-getclosestpointto OBJ (trans (cadr obj1) 1 0)) 
        p    (fix (+ 0.5 (vlax-curve-getparamatpoint OBJ p))) ;_拾取点在多段线中的位置 
        Pt   (vlax-safearray->list 
               (vlax-variant-value 
                 (vla-get-coordinate obj p) 
               ) 
             ) ;_返回第P个点的坐标 
  ) 
 
  (setq        pts (vlax-safearray->list 
              (variant-value (vla-get-coordinates obj)) 
            ) 
  ) 
  (setq        i 0 
        j (* 2 p) 
  ) 
  ;;将表中第P个点开始相同的点删除 
  ;; 
  ;;将第P个点前的所有点复制到ptl 
  (while (
    (setq ptl (append ptl (list (car pts) (cadr pts))) 
          pts (cddr pts) 
          i   (+ i 2) 
    ) 
  ) 
  ;;删除P点及其后相同的点 
  (while (and (= (car pt) (car pts)) 
              (= (cadr pt) (cadr pts)) 
         ) 
    (setq pts (cddr pts)) 
  ) 
  ;;将其余所有点复制到ptl 
  (setq ptl (append ptl pts)) 
  (if (>= (length ptl) 4) 
    (progn (setq narray        (vlax-make-safearray 
                          vlax-vbDouble 
                          (cons 0 (1- (length ptl))) 
                        ) 
           ) 
           (vla-put-coordinates obj (vlax-safearray-fill narray ptl)) 
    ) 
  ) 
)

其中对点表中删除指定点的坐标方法应该还有更好的方法！不知哪位可以优化？
不知有没有直接的VL函数支持，删除表中指定项功能。

狂刀 · 发表于 2005-2-15 02:06:06

提一个：既然“;;删除P点及其后相同的点”那还是没有做到唯一性，应该就删除“那个点”，其后相同的就不应该管了

;| ( 删除多义线的指定param参数顶点－狂刀.2005.2.15|;
(defun delpar (obj par / i n ps)
(setq i -1
n (length (vlax-safearray->list(vlax-variant-value (vla-get-coordinate obj 0))))
ps (vlax-get obj 'coordinates)
ps (apply 'append (mapcar '(lambda (x) (setq i (1+ i))
(if (= (fix (/ i n)) par)nil(list x)) )
ps
) )
)
(vlax-put obj 'coordinates ps)
)

GTJ116600 · 发表于 2013-6-14 09:59:25

多段线删掉顶点程序，正需要研究，就有了:lol

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

[讨论]：删除多义线顶点的程序 收集

[讨论]：删除多义线顶点的程序收集