[功能]沿曲线移动

admin

1. ;;;[功能]沿曲线移动 Move by curve=============================================
2. (defun C:Mee (/ ANG ANG1 ANG2 D0 D1 D2 DIS E0 P1 P2 SS)
3.   ;;(alert "沿曲线移动对象：\n 沿曲线上两点移动")
4.   (if (and
5.         (setq ss (LM:ssget "\n >移动对象:" '(((0 . "*")))))
6.         (setq e0 (Fsxm-entsel "\n >>选择曲线:"
7.                               '((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))
8.                  )
9.         )
10.         (setq p1 (getpoint "\n >>>移动基点:"))
11.         (setq p2 (getpoint "\n >>>移动到:"))
12.       )
13.     (progn
14.       (setq e0 (car e0))
15.       (setq p1 (vlax-curve-getclosestpointto e0 p1))
16.       (setq p2 (vlax-curve-getclosestpointto e0 p2))
17.       (setq d0        (- (vlax-curve-getDistAtPoint e0 p2)
18.                    (vlax-curve-getDistAtPoint e0 p1)
19.                 )
20.       )
21.       (setq dis (getreal (strcat "\n 移动距离<" (VL-PRINC-TO-STRING d0) ">:")))
22.       (if (not dis)
23.         (setq dis d0)
24.         ;;输入dis后，计算新p2
25.         (progn         
26.           (setq d1 (vlax-curve-getDistAtPoint e0 p1))
27.           (setq d2 (+ d1 dis))         
28.           (setq p2(vlax-curve-getPointAtDist e0 d2))
29.         )
30.       )
32.      (setq ang1 (vlax-curve-getParamAtPoint e0 p1))
33.      (setq ang1 (vlax-curve-getFirstDeriv e0 ang1))
34.      (setq ang1 (angle ang1 '(0 0 0)))
35.      (setq ang2 (vlax-curve-getParamAtPoint e0 p2))
36.      (setq ang2 (vlax-curve-getFirstDeriv e0 ang2))
37.      (setq ang2 (angle ang2 '(0 0 0)))
38.      (setq ang (/ (* (- ang2 ang1) 180) pi))     
39.       (ACET-UNDO-BEGIN)
40.       (vl-cmdf "采用.move" ss "" "non" p1 "non" p2)
41.       (vl-cmdf ".采用rotate" ss "" "non" p2 ang)
42.       (ACET-UNDO-END)
43.     )
44.   )
45.   (princ "\n沿曲线上两点移动对象 Mee")
46.   (princ)
47. )
48. (princ "\n 沿曲线上两点移动对象 Mee")
49. (princ)
50. ;;;[功能]沿曲线移动 Move by curve=============================================
51. "觉得好，就打赏"

复制代码