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

陌生人 · 发表于 2003-12-19 03:09:04

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

删除多义线顶点的程序见过不少,我在这里想讨论的是:

1.谁能写出最简洁的程序? 如下例shicai的程序,满足一般功能,不求面面俱到.

2.更进一步! 写出较为完善的功能,如尽量减少操作步骤;提供undo功能;同一个顶点有多个多义线重合时,能自动规避不相关的多义线;(这一点shicai的程序未能做到), 一个命令中能对多个多义线进行操作(用while等语句),不用一次一个

以下是从明经转贴的几个程序,看看大家还能写出更简洁的么?

出处: http://www.vba.cn/bbs/dispbbs.asp?boardID=3&ID=13951

by meflying

(defun c:test( / ent ents pt lst i)
(command "_.undo" "be")
(setq ent (car (entsel)))
(setq ents (entget ent))
(setq pt (getpoint "输入要删除的点:"))
(setq lst (member (cons 10 (reverse (cdr (reverse pt)))) ents))
(if lst
(progn
(setq lst (list (assoc 10 lst) (assoc 40 lst) (assoc 41 lst) (assoc 42 lst)))
(setq i 0)
(repeat 4
(setq ents (vl-remove (nth i lst) ents))
(setq i (1+ i))
)
)
)
(entmod ents)
(command "_.undo" "e")
(princ)
)

BY Shicai

(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)
)

另外:龙龙仔提出一个意见

;;MEFLYING
;;vl-remove會把相同的資料去掉
;;這樣會失去相同點 & 相同寬度 & 相同凸度的資料
;;LOCKMYEYE的復合線頂點編輯工具可供參考,等有空我也研究研究

复制代码

补充:
对龙龙仔的意见,我觉得可以用另外一个程序来处理-----精简/消除多义线重合顶点. 因为如果要删一个顶点,一般来说是在同一个点的重合顶点都处理的.要不,得删多少次啊.不过,毕竟这是较为特殊的例子.不知道大家的看法如何?

lsjjm · 发表于 2003-12-19 03:27:17

1. (defun c:test ()
  (vl-load-com)
  (setq p (getpoint "\npick point:"))
  (setq ent (ssname (ssget p) 0)
      obj (vlax-ename->vla-object ent))
  (setq pts (variant-value (vla-get-coordinates obj)))
  (setq nlist (vl-remove (car p)(vlax-safearray->list pts)))
  (setq nlist (vl-remove (cadr p) nlist))
  (setq narray (vlax-make-safearray
            vlax-vbDouble
         (cons 0 (1- (length nlist)))))
  (vla-put-coordinates obj (vlax-safearray-fill narray nlist))
  (princ)
)

2. 也把你的贴出来麻!

陌生人 · 发表于 2003-12-19 05:43:54

别急,先评析一下以上程序
1.meflying的(以下称程序1), 多了一步entsel,步骤减缓了.每改一个多义线的顶点都要先选实体; 这一点上shicai的(以下称程序2) 要先进一步;
2.程序1 (cons 10 (reverse (cdr (reverse pt)))) 转了两转,我觉得不如用(list 10 (car pt) (cadr pt)) 更简洁明了.
3.程序2 (ssget pt)只能返回一个实体,当有多个多义线在一个点重合的时候,(这还是挺常见的) 删除的往往不是我们所希望的那个.
4.两个程序都对10 40 41 42组码进行了处理,因此有些臃肿(程序2好些,只浪费了 member 那一行),其实不必对这几个组码都进行处理的.

长老的回复好快啊,佩服,终于看到一个vlsp版本的了
对于使用vlsp的看法,我是这样的: (这里vlsp指用vl开头的函数)
1.当用lsp无法达到vlsp的效果时(如求两个实体交点-lsp对文字,spline等就没办法了)
2.当用lsp明显运行效率比vlsp低时(对多个物体操作,或者复杂实体)
3,当用lsp写程序比用vlsp烦琐时
4.为了测试,对比vlsp的函数功能时
仅当以上情况下,我才会用vlsp写程序.因此,我觉得这个程序用vl写编程效率不高(不是运行效率),没有体现出以上所列的相对于lsp的优势,我觉得还是用lsp写简单.除了用那个vl-remove

一点个人意见,欢迎交流.

先贴一段很久以前写的程序其中一段,现在看来显然不够简洁

....
(while
(setq pt (getpoint "\n自动识别增/删--取点:")) ;enter--重新选择pl线
(if
(and (setq ptend (osnap pt "_end"))
(member (cons 10 ptend) entl)
)
(if (equal pt ptend)
(eplv);删除顶点
(aplv);增加顶点
)
);endif
); end while
(setvar "osmode" os)
(princ)
)
;;;;删除顶点
(defun eplv ()
(setq ptl (cons 10 pt);点对
entl2 '()
)
(foreach n entl
(if (not (equal n ptl))
(setq entl2 (cons n entl2))
)
)
(setq entl (reverse entl2))
(entmod entl)
)
;;;;增加顶点

都是我分析别人的,谁给我分析一下?呵呵
新的删除多义线顶点的程序已经写好.明天再发:) ,啊都快天亮了.睡觉去咯

aeo · 发表于 2003-12-20 20:29:04

应该象xd-api一样，写成增加（删除）第N个顶点，而得到第几个顶点是很容易的.

陌生人 · 发表于 2003-12-20 22:01:47

先看看效果:

陌生人 · 发表于 2003-12-22 03:01:56

以上演示的是最新版本
;|删除曲线顶点----------------陌生人2003.12
v1.0 2003.12 自动选实体,避开重合顶点的不同多义线;保留宽度凸度信息;
;|v1.1 2003.12 加入循环功能;加入undo功能;

今天给大家一点提示:
其实删除多义线顶点,不用10 40 4142每个组码都删除的.
只要删除了10,cad在返回的时候自动处理掉俑余代码.
这样程序写起来就清爽的多,可惜,我直到现在在明经和这里,都
没有见到能运用cad的这个好处来处理程序的.

陌生人 · 发表于 2003-12-23 01:18:27

自己顶一下,顺便发个东西(要不顶不了:) )
缩放实体后,字体高度保持不变.
其实要是用cad的一个命令,程序写起来很简单.如果有回贴.明天贴程序

luoyaya · 发表于 2003-12-23 19:06:04

陌生人
的居然还是一个FAS文件,晕死的,早知道不下的,
而且如果不选对象的话会可能删错对象,UNDO做得也不好,只是在里面加了一个COMMAND的UNDO如果次数太多的话会UNDO掉以前画的东西,
为什么没有用SSGET方式来选点呢?这样可以一次性删除多个点不好吗?

zuicai · 发表于 2003-12-23 19:19:58

陌生人，这个缩放的小程序能贴出来吗？我比较需要。

LUCAS · 发表于 2003-12-25 09:43:54

;;缩放的小程序
;;BY LUCAS
(defun C:TT (/ HOLDECHO SS SST PT SC N ENT)
(setq SS (ssget))
(if SS
(progn
(initget 1)
(setq PT (getpoint "\n指定基準點: "))
(initget 7)
(setq SC (getdist "\n比例: "))
(setq HOLDECHO (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command "_.UNDO" "_GROUP")
(command "_.SCALE" SS "" PT SC)
(setq SST (ssget "P" '((0 . "*TEXT"))))
(if SST
(vlax-for ENT (vla-get-activeselectionset
(vla-get-activedocument
(vlax-get-acad-object)
)
)
(vla-put-height ENT (/ (vla-get-height ENT) SC))
)
)
;|
(if SST
(progn
(setq N 0)
(repeat (sslength SST)
(setq ENT (entget (ssname SST N)))
(setq ENT (subst (cons 40 (/ (cdr (assoc 40 ENT)) SC))
(assoc 40 ENT)
ENT
)
)
(entmod ENT)
(setq N (1+ N))
)
)
)|;
)
)
(command "_.UNDO" "_END")
(setvar "CMDECHO" HOLDECHO)
(princ)
)

;;缩放的小程序 
;;BY LUCAS 
(defun C:TT (/ HOLDECHO SS SST PT SC N ENT) 
  (setq SS (ssget)) 
  (if SS 
    (progn 
      (initget 1) 
      (setq PT (getpoint "\n指定基準點: ")) 
      (initget 7) 
      (setq SC (getdist "\n比例: ")) 
      (setq HOLDECHO (getvar "CMDECHO")) 
      (setvar "CMDECHO" 0) 
      (command "_.UNDO" "_GROUP") 
      (command "_.SCALE" SS "" PT SC) 
      (setq SST (ssget "P" '((0 . "*TEXT")))) 
      (if SST 
        (vlax-for ENT (vla-get-activeselectionset 
                        (vla-get-activedocument 
                          (vlax-get-acad-object) 
                        ) 
                      ) 
          (vla-put-height ENT (/ (vla-get-height ENT) SC)) 
        ) 
      ) 
      ;| 
      (if SST 
        (progn 
          (setq N 0) 
          (repeat (sslength SST) 
            (setq ENT (entget (ssname SST N))) 
            (setq ENT (subst (cons 40 (/ (cdr (assoc 40 ENT)) SC)) 
                             (assoc 40 ENT) 
                             ENT 
                      ) 
            ) 
            (entmod ENT) 
            (setq N (1+ N)) 
          ) 
        ) 
      )|; 
    ) 
  ) 
  (command "_.UNDO" "_END") 
  (setvar "CMDECHO" HOLDECHO) 
  (princ) 
)

陌生人 · 发表于 2003-12-26 02:38:11

最初由 luoyaya 发布
[B]陌生人
的居然还是一个FAS文件,晕死的,早知道不下的,
而且如果不选对象的话会可能删错对象,UNDO做得也不好,只是在里面加了一个COMMAND的UNDO如果次数太多的话会UNDO掉以前画的东西,
为什么没有用SSGET方式来选?.. [/B]

你的建议很好.其实我早就想到了.但是现在没空了.
过几天再写吧;)
这个是原程序。你先自己改改

(defun c:delplpt (/ pt pti e ents)
(princ "删除多义线顶点----------------陌生人.2003.12")
(setq roop T)
(while roop
(initget " Undo eXit")
(setq pt (getpoint "\n选择要删除的多义线顶点/Undo/<eXit>:"))
(cond
((and (= 'LIST (type pt)) (setq e (ssget pt)))
(setq pt (osnap pt "nea")
pti(osnap pt "end")
ents (entget (ssname e 0))
entsav (cons ents entsav) ;需在此处设;
ents (vl-remove (list 10 (car pti)(cadr pti)) ents))
(entmod ents))
((= "Undo" pt) (setq ents (car entsav) entsav (cdr entsav)) (entmod ents))
((or (= "eXit" pt )(and (= nil pt)))
(setq roop nil))
)
);end while
(princ)
)

netbee · 发表于 2004-5-15 21:27:12

谁又有曲线上加点的程序呢？

陌生人 · 发表于 2004-5-15 22:45:23

小蜜蜂，以你的能力，这个不难吧？
回9楼，我的缩放程序：）比较简单

(defun c:sc2 (/ ss pt sc)
(princ "\n缩放----保留文字大小 by 陌生人.2003.10")
(princ "\n选择实体:")
(setq ss (ssget)
pt (getpoint "\n缩放基点:")
sc (getdist pt "\n缩放比:")
)
(command "_.scale" ss "" pt sc
"_.scaletext" ss "" "" "s" (/ 1 sc))
)
(princ)
)

呵呵，有没有人昏倒？

来个更强的，支持拖曳效果：
http://www.xdcad.net/forum/showthread.php?s=&threadid=183048
大家快去打擂啊

lsjjm · 发表于 2004-5-16 15:46:20

最初由 netbee 发布
[B]谁又有曲线上加点的程序呢？ [/B]

1. 你是说多义线吧? 请搜索论坛.
2. 曲线上加点--搞不懂?

netbee · 发表于 2004-5-16 15:51:45

最初由陌生人发布
[B]小蜜蜂，以你的能力，这个不难吧？
... [/B]

我用

(setq obj1(vlax-ename->vla-object (car (entsel)))
vpoint(vlax-3d-point (getpoint))
)
(vla-AddVertex obj1 2 vpoint)

却出错：
; 错误: Automation 错误。安全数组中的元素数目不正确
为什么？

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

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

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

点评

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

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

点评

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