[原创]：一个可以改变多义线顶点的LISP小程序

lsjjm

一个可以改变多义线顶点的LISP小程序

;;By Richard Liang
;;to move vertex of polyline
(defun c:test ()
  (vl-load-com)
  (setq p (getpoint "\nPick Point to move: ")
       pe (getpoint p "\nPick Destination Point: ")
      obj (vlax-ename->vla-object (ssname (ssget p) 0))
       pp (vlax-curve-getclosestpointto obj (trans p 1 0))
        n (fix (vlax-curve-getparamatpoint obj pp))
      pts (variant-value (vla-get-coordinates obj))
    nlist (reverse (vlax-safearray->list pts)))
  (setq pts (variant-value (vla-get-coordinates obj)))
  (vlax-safearray-put-element pts (* n 2)(car pe))
  (vlax-safearray-put-element pts (1+ (* n 2))(cadr pe))
  (setq nlist (vlax-safearray->list pts))
  (setq narray (vlax-make-safearray
                 vlax-vbDouble
                 (cons 0 (1- (length nlist)))))
  (vla-put-coordinates obj (vlax-safearray-fill narray nlist))
)

LUCAS

2. 
   
3. (defun C:TT (/ P PE OBJ PP N PTS OBJ1)
   
4.   (vl-load-com)
   
5.   (setq        P   (getpoint "\nPick Point to move: ")
   
6.         PE  (getpoint P "\nPick Destination Point: ")
   
7.         OBJ (vlax-ename->vla-object (setq OBJ1 (ssname (ssget P) 0)))
   
8.         PP  (vlax-curve-getclosestpointto OBJ (trans P 1 0))
   
9.         N   (fix (vlax-curve-getparamatpoint OBJ PP))
   
10.         PTS (variant-value (vla-get-coordinates OBJ))
    
11.   )
    
12.   (if (= "LWPOLYLINE" (cdr (assoc 0 (entget OBJ1))))
    
13.     (progn
    
14.       (vlax-safearray-put-element PTS (* N 2) (car PE))
    
15.       (vlax-safearray-put-element PTS (1+ (* N 2)) (cadr PE))
    
16.     )
    
17.     (progn
    
18.       (vlax-safearray-put-element PTS (* N 3) (car PE))
    
19.       (vlax-safearray-put-element PTS (1+ (* N 3)) (cadr PE))
    
20.       (vlax-safearray-put-element PTS (+ (* N 3) 2) (last PE))
    
21.     )
    
22.   )
    
23.   (vla-put-coordinates OBJ PTS)
    
24. )
    

<br /> (defun C:TT (/ P PE OBJ PP N PTS OBJ1)<br />   (vl-load-com)<br />   (setq        P   (getpoint "\nPick Point to move: ")<br />         PE  (getpoint P "\nPick Destination Point: ")<br />         OBJ (vlax-ename->vla-object (setq OBJ1 (ssname (ssget P) 0)))<br />         PP  (vlax-curve-getclosestpointto OBJ (trans P 1 0))<br />         N   (fix (vlax-curve-getparamatpoint OBJ PP))<br />         PTS (variant-value (vla-get-coordinates OBJ))<br />   )<br />   (if (= "LWPOLYLINE" (cdr (assoc 0 (entget OBJ1))))<br />     (progn<br />       (vlax-safearray-put-element PTS (* N 2) (car PE))<br />       (vlax-safearray-put-element PTS (1+ (* N 2)) (cadr PE))<br />     )<br />     (progn<br />       (vlax-safearray-put-element PTS (* N 3) (car PE))<br />       (vlax-safearray-put-element PTS (1+ (* N 3)) (cadr PE))<br />       (vlax-safearray-put-element PTS (+ (* N 3) 2) (last PE))<br />     )<br />   )<br />   (vla-put-coordinates OBJ PTS)<br /> )<br />

lsjjm

2楼倒ti xing了我, 清除重复部分简化如下:

(defun c:test ()
  (vl-load-com)
  (setq        p     (getpoint "\nPick Point to move: ")
        pe    (getpoint p "\nPick Destination Point: ")
        obj   (vlax-ename->vla-object (ssname (ssget p) 0))
        pp    (vlax-curve-getclosestpointto obj (trans p 1 0))
        n     (fix (vlax-curve-getparamatpoint obj pp))
        pts   (variant-value (vla-get-coordinates obj)))
  (vlax-safearray-put-element pts (* n 2) (car pe))
  (vlax-safearray-put-element pts (1+ (* n 2)) (cadr pe))
  (vla-put-coordinates obj pts)
)

wkai

用 夹点 移动不是很好么？
为什么要写这个程序呢？

lsjjm

最初由 wkai 发布
[B]用 夹点 移动不是很好么？
为什么要写这个程序呢？ [/B]

对于某一操作, AutoCAD不仅提供了命令行, 菜单还提供了 AutoLISP, VBA等为什么呢? 就是为了用户自动化和二次开发.
对一般性操作而言, 使用夹点或PEDIT即可.但在某些场合下需使用程序来激发AUTOCAD作某一动作.

wkai

最初由 lsjjm 发布
[B]
但在某些场合下需使用程序来激发AUTOCAD作某一动作 [/B]

有道理，谢谢！

陌生人

不用vla也很能简短

2. 
   
3. (defun x@chpt ();(e frompt topt)
   
4.   (setq e (car(setq el (entsel))) frompt (osnap (cadr el) "end") topt (getpoint frompt "\n顶点移动到:"))
   
5.   (setq en (entget e)
   
6.         frompt (list (car frompt)(cadr frompt))
   
7.         pt (car (member (cons 10 frompt) (entget e)))
   
8.         en (subst (cons 10 (list (car topt)(cadr topt))) pt en))
   
9.   (entmod en)
   
10. )

<br /> (defun x@chpt ();(e frompt topt)<br />   (setq e (car(setq el (entsel))) frompt (osnap (cadr el) "end") topt (getpoint frompt "\n顶点移动到:"))<br />   (setq en (entget e)<br />         frompt (list (car frompt)(cadr frompt))<br />         pt (car (member (cons 10 frompt) (entget e)))<br />         en (subst (cons 10 (list (car topt)(cadr topt))) pt en))<br />   (entmod en)<br /> )

另外建议 所有上贴 fix 前加 0.5，这样能选到靠近的顶点
eg
(fix (+ 0.5 (vlax-curve-getParamAtPoint e (vlax-curve-getclosestpointto e frompt))))