悬挂点加点的程序，请各位帮助解决一下，谢谢

chlh_jd

以其如此，不如自己动手；
ET扩展插件好像有(重新找下没找到）；
Theswamp.org上面有1个，ronjonp 写的
http://www.theswamp.org/index.php?topic=18720.30

2. 
   
3. (defun c:addvertex (/ ent i nlst obj p pt x)
   
4.   (vl-load-com)
   
5.   (while (setq ent (entsel "\nSelect point on polyline to add vertex: "))
   
6.     (if         (and ent (= (cdr (assoc 0 (entget (car ent)))) "LWPOLYLINE"))
   
7.       (progn (setq i         (fix (vlax-curve-getparamatpoint
   
8.                                 (car ent)
   
9.                                 (setq p (vlax-curve-getclosestpointto (car ent) (cadr ent)))
   
10.                               )
    
11.                          )
    
12.                     obj         (vlax-ename->vla-object (car ent))
    
13.                     pt         (vlax-curve-getpointatparam (car ent) i)
    
14.                     nlst         nil
    
15.               )
    
16.               (mapcar '(lambda (x)
    
17.                          (if (equal x (list 10 (car pt) (cadr pt)) 0.0001)
    
18.                            (setq         nlst (cons x nlst)
    
19.                                  nlst (cons (list 10 (car p) (cadr p)) nlst)
    
20.                            )
    
21.                            (setq nlst (cons x nlst))
    
22.                          )
    
23.                        )
    
24.                       (entget (car ent))
    
25.               )
    
26.               (entmod (reverse nlst))
    
27.               (entupd (car ent))
    
28.               (sssetfirst nil (ssadd (car ent)))
    
29.       )
    
30.     )
    
31.   )
    
32.   (sssetfirst nil)
    
33.   (princ)
    
34. )
    

<br /> (defun c:addvertex (/ ent i nlst obj p pt x)<br />   (vl-load-com)<br />   (while (setq ent (entsel "\nSelect point on polyline to add vertex: "))<br />     (if         (and ent (= (cdr (assoc 0 (entget (car ent)))) "LWPOLYLINE"))<br />       (progn (setq i         (fix (vlax-curve-getparamatpoint<br />                                 (car ent)<br />                                 (setq p (vlax-curve-getclosestpointto (car ent) (cadr ent)))<br />                               )<br />                          )<br />                     obj         (vlax-ename->vla-object (car ent))<br />                     pt         (vlax-curve-getpointatparam (car ent) i)<br />                     nlst         nil<br />               )<br />               (mapcar '(lambda (x)<br />                          (if (equal x (list 10 (car pt) (cadr pt)) 0.0001)<br />                            (setq         nlst (cons x nlst)<br />                                  nlst (cons (list 10 (car p) (cadr p)) nlst)<br />                            )<br />                            (setq nlst (cons x nlst))<br />                          )<br />                        )<br />                       (entget (car ent))<br />               )<br />               (entmod (reverse nlst))<br />               (entupd (car ent))<br />               (sssetfirst nil (ssadd (car ent)))<br />       )<br />     )<br />   )<br />   (sssetfirst nil)<br />   (princ)<br /> )<br />

soly2006

chlh_jd 发表于 2012-8-7 20:37
以其如此，不如自己动手；
ET扩展插件好像有(重新找下没找到）；
Theswamp.org上面有1个，ronjonp 写的

非常感谢，这个实现多段线加点功能，如能有判断悬挂位置就好了。

vexation

soly2006 发表于 2012-8-6 12:58
没用过，可以转到cad吗？

这个就是CAD，但是多了个地图功能，里面就可以拓扑，伪节点、悬挂点都可以查 你在网上找找Autodesk Map2004应该有的

soly2006

已做出小样，放出来让大家批评。

2. ;;检查悬挂点 通版
   
3. ;;2012-8-9 soly2006 可用
   
4. (defun c:xuangua( / 集1 i 图元表1 点表1 图元1 点1)
   
5.   (setq 图元表1 NIL
   
6.         图元表2 NIL
   
7.   )
   
8.   (setq 集1 (ssget '((0 . "lwpolyline"))))
   
9.   (setq 图元表1 (集转表 集1 ))  ;把图元名做成表
   
10.   (foreach 图元1 图元表1
    
11.    (setq 点表1 (GETPLVTX 图元1))  ;取得点表
    
12.    (foreach 点1 点表1
    
13.      (setq 集2 (ssget "cp" (jn-cpts 点1 0.1 100) '((0 . "lwpolyline"))))
    
14.        
    
15.      (setq 图元表2 (集转表 集2 ))  ;把图元名做成表
    
16.   
    
17.          (setq 图元表2 (vl-remove 图元1 图元表2))
    
18.          (while 图元表2
    
19.            (setq 点表2 (GETPLVTX (car 图元表2)) )
    
20. 
    
21.            (if (and (not (member 点1 点表2))
    
22.                     (equal (distance (vlax-curve-getClosestPointTo (vlax-ename->vla-object (car 图元表2)) 点1) 点1) 0.0))
    
23.             (progn
    
24.                 (mkcircle 点1 1)  ;标记
    
25.                 (inspttopl (car 图元表2) 点1)  ;增加结点
    
26.                 )
    
27.            )
    
28.            (setq 图元表2 (cdr 图元表2))
    
29.          )
    
30.    )
    
31.   )
    
32. )
    
33. 
    
34. ;;---------------标记出错位置------------------------
    
35. (defun mkcircle  (pt r)
    
36.     (entmake (list '(0 . "circle")
    
37.                    (cons 10 pt)
    
38.                    (cons 40 r)
    
39.                    (cons 62 1) ;颜色
    
40.                    (cons 8 "检查标记")))
    
41. )
    
42. 
    
43. ;;求多段线顶点----不知谁编的-------
    
44. (defun GETPLVTX (E / ED )
    
45. (defun DXF (NO)
    
46. (cdr (assoc NO ED))
    
47. )
    
48. (defun GETLWPL (ED / PL)
    
49. (while (setq ED (cdr (member (setq PL10 (assoc 10 ED))
    
50.      ED
    
51.     )   )  )
    
52. (setq PL (cons (cdr PL10) PL))
    
53. )
    
54. (reverse PL)
    
55. )
    
56. (defun GETPL (ED / E PL P10)
    
57. (setq E (DXF -1))
    
58. (while (setq E (entnext E))
    
59. (if (setq P10 (cdr (assoc 10 (entget E))))
    
60.   (setq PL (cons P10 PL))
    
61. ))
    
62. (reverse PL)
    
63. )
    
64. (setq ED (entget E))
    
65. (setq PLTYPE (DXF 0))
    
66. (cond
    
67. ((= "POLYLINE" PLTYPE)
    
68. (GETPL ED))
    
69. ((= "LWPOLYLINE" PLTYPE)
    
70. (GETLWPL ED))))
    
71. ;;---------------
    
72. ;; | ---------------------------------------------------------------------------
    
73. ;; | jn-cpts
    
74. ;; | ---------------------------------------------------------------------------
    
75. ;; | Function :  给定一个中心点和半径,等分数，返回圆上点列表
    
76. ;; | Argument : (jn-cpts cpt r div-num)
    
77. ;; | Returns  : 返回圆上点列表
    
78. ;; | Updated  : 2012-5-4
    
79. ;; | ---------------------------------------------------------------------------
    
80. (defun jn-cpts(cpt r div-num / ptl parti-deg jd ) ;求圆上点传入中心点和半径
    
81. (setq ptl NIL )
    
82. (setq parti-deg (/ (* 2.0 PI) div-num))
    
83. (setq jd parti-deg)
    
84. (while (< jd (* 2 PI))
    
85. (setq ptl (append (list (polar cpt jd r)) ptl))
    
86. (setq jd (+ parti-deg jd))
    
87. )
    
88. (setq ptl ptl)
    
89. )
    
90. ;;PL线插入点 多谢chlh_jd提供，在此修改成函数
    
91. ;;2012-8-9
    
92. (defun inspttopl(ent pt0 / i nlst obj p pt x)
    
93.      (setq i (fix (vlax-curve-getparamatpoint
    
94.                       ent
    
95.                       (setq p (vlax-curve-getclosestpointto ent pt0))
    
96.                    )
    
97.               )  ;取得插入点前的顶点线参数
    
98.          obj         (vlax-ename->vla-object ent)
    
99.          pt         (vlax-curve-getpointatparam ent i)
    
100.          nlst         nil
     
101.       )
     
102.               (mapcar '(lambda (x)
     
103.                          (if (equal x (list 10 (car pt) (cadr pt)) 0.0001)
     
104.                            (setq         nlst (cons x nlst)
     
105.                                          nlst (cons (list 10 (car p) (cadr p)) nlst) ;此处p = pt0
     
106.                            )
     
107.                            (setq nlst (cons x nlst))
     
108.                          )
     
109.                        )
     
110.                       (entget ent)
     
111.               )
     
112.               (entmod (reverse nlst))
     
113.               (entupd ent)
     
114.               (sssetfirst nil (ssadd ent))
     
115.   (sssetfirst nil)
     
116.   (princ)
     
117. )
     
118. 
     
119. ;;-----------------------------ss2lst---------------------------------
     
120. ;;                          选择集转实体名表2012-7-24 soly2006 修改
     
121. ;;用法 (ss2lst ss)返回实体名表或空
     
122. (defun 集转表 ( ss / i L )
     
123. (setq L NIL)
     
124.     (if ss
     
125.         (repeat (setq i (sslength ss))
     
126.             (setq l (cons (ssname ss (setq i (1- i))) l))
     
127.         )
     
128.     )
     
129.         L
     
130. )

;;检查悬挂点 通版<br /> ;;2012-8-9 soly2006 可用<br /> (defun c:xuangua( / 集1 i 图元表1 点表1 图元1 点1)<br />   (setq 图元表1 NIL<br />         图元表2 NIL<br />   )<br />   (setq 集1 (ssget '((0 . "lwpolyline"))))<br />   (setq 图元表1 (集转表 集1 ))  ;把图元名做成表<br />   (foreach 图元1 图元表1<br />    (setq 点表1 (GETPLVTX 图元1))  ;取得点表<br />    (foreach 点1 点表1<br />      (setq 集2 (ssget "cp" (jn-cpts 点1 0.1 100) '((0 . "lwpolyline"))))<br />         <br />      (setq 图元表2 (集转表 集2 ))  ;把图元名做成表<br />   <br />          (setq 图元表2 (vl-remove 图元1 图元表2))<br />          (while 图元表2 <br />            (setq 点表2 (GETPLVTX (car 图元表2)) )<br /> <br />            (if (and (not (member 点1 点表2)) <br />                     (equal (distance (vlax-curve-getClosestPointTo (vlax-ename->vla-object (car 图元表2)) 点1) 点1) 0.0))<br />             (progn<br />                 (mkcircle 点1 1)  ;标记<br />                 (inspttopl (car 图元表2) 点1)  ;增加结点<br />                 )<br />            )<br />            (setq 图元表2 (cdr 图元表2))<br />          )<br />    )<br />   )<br /> )<br /> <br /> ;;---------------标记出错位置------------------------<br /> (defun mkcircle  (pt r) <br />     (entmake (list '(0 . "circle")<br />                    (cons 10 pt)<br />                    (cons 40 r)<br />                    (cons 62 1) ;颜色<br />                    (cons 8 "检查标记")))<br /> )<br /> <br /> ;;求多段线顶点----不知谁编的-------<br /> (defun GETPLVTX (E / ED )<br /> (defun DXF (NO)<br /> (cdr (assoc NO ED))<br /> )<br /> (defun GETLWPL (ED / PL)<br /> (while (setq ED (cdr (member (setq PL10 (assoc 10 ED))<br />      ED<br />     )   )  )<br /> (setq PL (cons (cdr PL10) PL))<br /> )<br /> (reverse PL)<br /> )<br /> (defun GETPL (ED / E PL P10)<br /> (setq E (DXF -1))<br /> (while (setq E (entnext E))<br /> (if (setq P10 (cdr (assoc 10 (entget E))))<br />   (setq PL (cons P10 PL))<br /> ))<br /> (reverse PL)<br /> )<br /> (setq ED (entget E))<br /> (setq PLTYPE (DXF 0))<br /> (cond<br /> ((= "POLYLINE" PLTYPE)<br /> (GETPL ED))<br /> ((= "LWPOLYLINE" PLTYPE)<br /> (GETLWPL ED))))<br /> ;;---------------<br /> ;; | ---------------------------------------------------------------------------<br /> ;; | jn-cpts<br /> ;; | ---------------------------------------------------------------------------<br /> ;; | Function :  给定一个中心点和半径,等分数，返回圆上点列表<br /> ;; | Argument : (jn-cpts cpt r div-num)<br /> ;; | Returns  : 返回圆上点列表<br /> ;; | Updated  : 2012-5-4<br /> ;; | ---------------------------------------------------------------------------<br /> (defun jn-cpts(cpt r div-num / ptl parti-deg jd ) ;求圆上点传入中心点和半径<br /> (setq ptl NIL )<br /> (setq parti-deg (/ (* 2.0 PI) div-num))<br /> (setq jd parti-deg)<br /> (while (< jd (* 2 PI))<br /> (setq ptl (append (list (polar cpt jd r)) ptl))<br /> (setq jd (+ parti-deg jd))<br /> )<br /> (setq ptl ptl)<br /> )<br /> ;;PL线插入点 多谢chlh_jd提供，在此修改成函数<br /> ;;2012-8-9<br /> (defun inspttopl(ent pt0 / i nlst obj p pt x)<br />      (setq i (fix (vlax-curve-getparamatpoint<br />                       ent<br />                       (setq p (vlax-curve-getclosestpointto ent pt0))<br />                    )<br />               )  ;取得插入点前的顶点线参数<br />          obj         (vlax-ename->vla-object ent)<br />          pt         (vlax-curve-getpointatparam ent i)<br />          nlst         nil<br />       )<br />               (mapcar '(lambda (x)<br />                          (if (equal x (list 10 (car pt) (cadr pt)) 0.0001)<br />                            (setq         nlst (cons x nlst)<br />                                          nlst (cons (list 10 (car p) (cadr p)) nlst) ;此处p = pt0<br />                            )<br />                            (setq nlst (cons x nlst))<br />                          )<br />                        )<br />                       (entget ent)<br />               )<br />               (entmod (reverse nlst))<br />               (entupd ent)<br />               (sssetfirst nil (ssadd ent))<br />   (sssetfirst nil)<br />   (princ)<br /> )<br /> <br /> ;;-----------------------------ss2lst---------------------------------<br /> ;;                          选择集转实体名表2012-7-24 soly2006 修改<br /> ;;用法 (ss2lst ss)返回实体名表或空<br /> (defun 集转表 ( ss / i L )<br /> (setq L NIL)<br />     (if ss<br />         (repeat (setq i (sslength ss))<br />             (setq l (cons (ssname ss (setq i (1- i))) l))<br />         )<br />     )<br />         L<br /> )

soly2006

用了有些加不上，各位有好的程序吗？这里谢谢了。

yx5277

soly2006 发表于 2012-11-6 02:13
用了有些加不上，各位有好的程序吗？这里谢谢了。

我这也有一个手动单个加点的小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)))
    )
  )
)

soly2006

yx5277 发表于 2012-11-9 15:29
我这也有一个手动单个加点的小LISP程序，你看能否用得上，这也是从网上收集来的：
;给复义线增加节点，而 ...

好像对二维多段线没用，会出乱，多段线稍好

zyhandw

用cad做gis好累

soly2006

zyhandw 发表于 2012-11-10 11:09
用cad做gis好累

同道中人啊
期待有高人解决

dalin1985

顶一下，非常需要。