[功能]沿曲线移动
;;;[功能]沿曲线移动 Move by curve=============================================(defun C:Mee (/ ANG ANG1 ANG2 D0 D1 D2 DIS E0 P1 P2 SS)
;;(alert "沿曲线移动对象：\n 沿曲线上两点移动")
(if (and
(setq ss (LM:ssget "\n >移动对象:" '(((0 . "*")))))
(setq e0 (Fsxm-entsel "\n >>选择曲线:"
'((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))
)
)
(setq p1 (getpoint "\n >>>移动基点:"))
(setq p2 (getpoint "\n >>>移动到:"))
)
(progn
(setq e0 (car e0))
(setq p1 (vlax-curve-getclosestpointto e0 p1))
(setq p2 (vlax-curve-getclosestpointto e0 p2))
(setq d0 (- (vlax-curve-getDistAtPoint e0 p2)
(vlax-curve-getDistAtPoint e0 p1)
)
)
(setq dis (getreal (strcat "\n 移动距离<" (VL-PRINC-TO-STRING d0) ">:")))
(if (not dis)
(setq dis d0)
;;输入dis后，计算新p2
(progn
(setq d1 (vlax-curve-getDistAtPoint e0 p1))
(setq d2 (+ d1 dis))
(setq p2(vlax-curve-getPointAtDist e0 d2))
)
)
(setq ang1 (vlax-curve-getParamAtPoint e0 p1))
(setq ang1 (vlax-curve-getFirstDeriv e0 ang1))
(setq ang1 (angle ang1 '(0 0 0)))
(setq ang2 (vlax-curve-getParamAtPoint e0 p2))
(setq ang2 (vlax-curve-getFirstDeriv e0 ang2))
(setq ang2 (angle ang2 '(0 0 0)))
(setq ang (/ (* (- ang2 ang1) 180) pi))
(ACET-UNDO-BEGIN)
(vl-cmdf "采用.move" ss "" "non" p1 "non" p2)
(vl-cmdf ".采用rotate" ss "" "non" p2 ang)
(ACET-UNDO-END)
)
)
(princ "\n沿曲线上两点移动对象 Mee")
(princ)
)
(princ "\n 沿曲线上两点移动对象 Mee")
(princ)
;;;[功能]沿曲线移动 Move by curve=============================================
"觉得好，就打赏"
页:
[1]