本帖最后由 chlh_jd 于 2012-8-7 20:38 编辑
以其如此，不如自己动手；
ET扩展插件好像有(重新找下没找到）；
Theswamp.org上面有1个，ronjonp 写的
http://www.theswamp.org/index.php?topic=18720.30
(defun c:addvertex (/ ent i nlst obj p pt x)
(vl-load-com)
(while (setq ent (entsel "\nSelect point on polyline to add vertex: "))
(if (and ent (= (cdr (assoc 0 (entget (car ent)))) "LWPOLYLINE"))
(progn (setq i (fix (vlax-curve-getparamatpoint
(car ent)
(setq p (vlax-curve-getclosestpointto (car ent) (cadr ent)))
)
)
obj (vlax-ename->vla-object (car ent))
pt (vlax-curve-getpointatparam (car ent) i)
nlst nil
)
(mapcar '(lambda (x)
(if (equal x (list 10 (car pt) (cadr pt)) 0.0001)
(setq nlst (cons x nlst)
nlst (cons (list 10 (car p) (cadr p)) nlst)
)
(setq nlst (cons x nlst))
)
)
(entget (car ent))
)
(entmod (reverse nlst))
(entupd (car ent))
(sssetfirst nil (ssadd (car ent)))
)
)
)
(sssetfirst nil)
(princ)
)
chlh_jd 发表于 2012-8-7 20:37 static/image/common/back.gif
以其如此，不如自己动手；
ET扩展插件好像有(重新找下没找到）；
Theswamp.org上面有1个，ronjonp 写的
非常感谢，这个实现多段线加点功能，如能有判断悬挂位置就好了。
soly2006 发表于 2012-8-6 12:58 static/image/common/back.gif
没用过，可以转到cad吗？
这个就是CAD，但是多了个地图功能，里面就可以拓扑，伪节点、悬挂点都可以查 你在网上找找Autodesk Map2004应该有的
本帖最后由 soly2006 于 2012-8-8 18:16 编辑
已做出小样，放出来让大家批评。
;;检查悬挂点 通版
;;2012-8-9 soly2006 可用
(defun c:xuangua( / 集1 i 图元表1 点表1 图元1 点1)
(setq 图元表1 NIL
图元表2 NIL
)
(setq 集1 (ssget '((0 . "lwpolyline"))))
(setq 图元表1 (集转表 集1 ));把图元名做成表
(foreach 图元1 图元表1
(setq 点表1 (GETPLVTX 图元1));取得点表
(foreach 点1 点表1
(setq 集2 (ssget "cp" (jn-cpts 点1 0.1 100) '((0 . "lwpolyline"))))
(setq 图元表2 (集转表 集2 ));把图元名做成表
(setq 图元表2 (vl-remove 图元1 图元表2))
(while 图元表2
(setq 点表2 (GETPLVTX (car 图元表2)) )
(if (and (not (member 点1 点表2))
(equal (distance (vlax-curve-getClosestPointTo (vlax-ename->vla-object (car 图元表2)) 点1) 点1) 0.0))
(progn
(mkcircle 点1 1);标记
(inspttopl (car 图元表2) 点1);增加结点
)
)
(setq 图元表2 (cdr 图元表2))
)
)
)
)
;;---------------标记出错位置------------------------
(defun mkcircle(pt r)
(entmake (list '(0 . "circle")
(cons 10 pt)
(cons 40 r)
(cons 62 1) ;颜色
(cons 8 "检查标记")))
)
;;求多段线顶点----不知谁编的-------
(defun GETPLVTX (E / ED )
(defun DXF (NO)
(cdr (assoc NO ED))
)
(defun GETLWPL (ED / PL)
(while (setq ED (cdr (member (setq PL10 (assoc 10 ED))
ED
) ))
(setq PL (cons (cdr PL10) PL))
)
(reverse PL)
)
(defun GETPL (ED / E PL P10)
(setq E (DXF -1))
(while (setq E (entnext E))
(if (setq P10 (cdr (assoc 10 (entget E))))
(setq PL (cons P10 PL))
))
(reverse PL)
)
(setq ED (entget E))
(setq PLTYPE (DXF 0))
(cond
((= "POLYLINE" PLTYPE)
(GETPL ED))
((= "LWPOLYLINE" PLTYPE)
(GETLWPL ED))))
;;---------------
;; | ---------------------------------------------------------------------------
;; | jn-cpts
;; | ---------------------------------------------------------------------------
;; | Function :给定一个中心点和半径,等分数，返回圆上点列表
;; | Argument : (jn-cpts cpt r div-num)
;; | Returns: 返回圆上点列表
;; | Updated: 2012-5-4
;; | ---------------------------------------------------------------------------
(defun jn-cpts(cpt r div-num / ptl parti-deg jd ) ;求圆上点传入中心点和半径
(setq ptl NIL )
(setq parti-deg (/ (* 2.0 PI) div-num))
(setq jd parti-deg)
(while (< jd (* 2 PI))
(setq ptl (append (list (polar cpt jd r)) ptl))
(setq jd (+ parti-deg jd))
)
(setq ptl ptl)
)
;;PL线插入点 多谢chlh_jd提供，在此修改成函数
;;2012-8-9
(defun inspttopl(ent pt0 / i nlst obj p pt x)
(setq i (fix (vlax-curve-getparamatpoint
ent
(setq p (vlax-curve-getclosestpointto ent pt0))
)
);取得插入点前的顶点线参数
obj (vlax-ename->vla-object ent)
pt (vlax-curve-getpointatparam ent i)
nlst nil
)
(mapcar '(lambda (x)
(if (equal x (list 10 (car pt) (cadr pt)) 0.0001)
(setq nlst (cons x nlst)
nlst (cons (list 10 (car p) (cadr p)) nlst) ;此处p = pt0
)
(setq nlst (cons x nlst))
)
)
(entget ent)
)
(entmod (reverse nlst))
(entupd ent)
(sssetfirst nil (ssadd ent))
(sssetfirst nil)
(princ)
)
;;-----------------------------ss2lst---------------------------------
;; 选择集转实体名表2012-7-24 soly2006 修改
;;用法 (ss2lst ss)返回实体名表或空
(defun 集转表 ( ss / i L )
(setq L NIL)
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (ssname ss (setq i (1- i))) l))
)
)
L
)
用了有些加不上，各位有好的程序吗？这里谢谢了。
soly2006 发表于 2012-11-6 02:13 static/image/common/back.gif
用了有些加不上，各位有好的程序吗？这里谢谢了。
我这也有一个手动单个加点的小LISP程序，你看能否用得上，这也是从网上收集来的：
;给复义线增加节点，而不改变复义线的形状，特殊的场合用得到。
(defun c:Pladd ( / obj ent pp n m m1 m2 pn newv bg1 bg2 a b bg p1)
(setq OBJ(vlax-ename->vla-object (car (setq ent (entsel))))
p1 (getpoint"\n选加入的点,回车缺省:")
PP (vlax-curve-getclosestpointto OBJ (if p1 p1(cadr ent)))
N (fix (setq m (vlax-curve-getparamatpoint OBJ PP)))
m1 (- m n)
m2 (- 1 m1)
bg (vla-getbulge obj n)
pn pp
PN (list (car PN) (cadr PN))
NEWV (vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble '(0 . 1))
PN
)
)
(vla-addvertex OBJ (1+ N) NEWV)
(if (/= 0 bg)
(progn
(setq a (* (atan bg) m1))
(setq b (* (atan bg) m2))
(vla-setbulge obj n (/ (sin a) (cos a)))
(vla-setbulge obj (1+ n) (/ (sin b) (cos b)))
)
)
)
yx5277 发表于 2012-11-9 15:29 static/image/common/back.gif
我这也有一个手动单个加点的小LISP程序，你看能否用得上，这也是从网上收集来的：
;给复义线增加节点，而 ...
好像对二维多段线没用，会出乱，多段线稍好
用cad做gis好累
zyhandw 发表于 2012-11-10 11:09 static/image/common/back.gif
用cad做gis好累
同道中人啊
期待有高人解决
顶一下，非常需要。