[编程交流] 遵循路径

(vl-load-com)
(defun test (/
     Dist
     EndDist
     EndPoint
     Fuzz
     LineLength
     BlockObj
     PathObj
     StartPoint
     Step
     Point1
     Point2
     MSpaceObj
    )
 (setq MSpaceObj (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
 (princ "\nSelect BLOCK: ")
 (setq        BlockObj   (vlax-ename->vla-object (car (entsel)))
Point1           (vlax-safearray->list
             (vlax-variant-value (vla-get-InsertionPoint BlockObj))
           )
Point2           (getpoint Point1 "\nPick location point 2: ")
LineLength (distance Point1 Point2)
 )
 (princ "\nSelect PATH: ")
 (setq PathObj (vlax-ename->vla-object (car (entsel))))
 (setq EndDist (vlax-curve-getDistAtParam PathObj (vlax-curve-getEndParam PathObj)))
 (setq        Step (getreal "\nEnter stepping distance: ")
Fuzz 0.01
Dist 0.0
 )
 (while (< Dist EndDist)
   (setq StartPoint (vlax-curve-getPointAtDist PathObj Dist))
   (while (and        (< (setq Dist (+ Dist Fuzz)) EndDist)
        (< (distance StartPoint
                     (setq EndPoint (vlax-curve-getPointAtDist PathObj Dist))
           )
           LineLength
        )
   )
   )
   (if        (< Dist EndDist)
     (progn (vla-InsertBlock
       MSpaceObj
       (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble '(0 . 2)) StartPoint))
       (vla-Get-Name BlockObj)
       1.0
       1.0
       1.0
       (angle StartPoint EndPoint)
     )
     (setq Dist (+ Dist Step))
     )
   )
 )
 (vlax-release-object PathObj)
 (vlax-release-object BlockObj)
 (vlax-release-object MSpaceObj)
 (princ)
)

;;;===========================================
;;;Move objects along curve path
;;;Written by ssg - October 25th, 2007
;;;===========================================
;;;-------------------------------------------------------------------------------
(defun rtd(x) (/ (* x 180) pi) ) ;;;Change radian to degree
;;;-------------------------------------------------------------------------------
(defun Collect(e / ent2 SS1 SS2) ;;;Selection set from e to entlast
(setq SS1 (ssadd))
(ssadd e SS1)
(while (setq ent2 (entnext e)) 
   (ssadd ent2 SS1)
   (setq e ent2)
)
(setq SS2 SS1)
)
;;;-------------------------------------------------------------------------------
(defun Collect1(e / ss)
;;;Selection set after e to entlast. If e nil, select from fist entity of drawing.
(if (= e nil) (setq ss (collect (entnext)))
   (progn (setq ss (collect e)) (ssdel e ss))
)
)
;;;-------------------------------------------------------------------------------
(defun ints (e1 e2 / ob1 ob2 V L1 L2)
;;;Get intersections of e1, e2. Return LIST of points
(setq
   ob1 (vlax-ename->vla-object e1)
   ob2 (vlax-ename->vla-object e2)
)
(setq V (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound V 1) -1)
   (progn
         (setq L1 (vlax-safearray->list V) L2 nil)
         (while L1
(setq L2 (append L2 (list (list (car L1) (cadr L1) (caddr L1)))))
(repeat 3 (setq L1 (cdr L1)))
         )
   )
   (setq L2 nil)
)
L2
)
;;;------------------------------------------------------------------------------
(defun getnearP (p p1 p2) ;;;Get nearer point by p. Return p1 or p2
(if (<= (distance p p1) (distance p p2)) p1 p2)
)
;;;------------------------------------------------------------------------------
(defun getpL(e st / el ss i et p pL)
;;;Get list of points by measure command, specified by curve e and step st
(setq el (entlast))
(command "measure" e st )
(setq ss (collect1 el) i 0)
(repeat (sslength ss) 
   (setq
       et (ssname ss i)
       p (cdr (assoc 10 (entget et)))
       pL (append pL (list p))
       i (1+ i)
   )
)
(command "erase" ss "")
pL
)
;;;------------------------------------------------------------------------------
(defun MoveStep()
(repeat (length pL)
   (setq p3 (nth j pL))
   (setq pa3 (vlax-curve-getParamAtPoint cur p3))
   (if (>= (* flag pa3) (* flag pa1))
       (progn
           (command "circle" p3 r) 
           (setq ipL (ints cur (entlast)))
           (if (> (length ipL) 1)
               (setq p4 (getnearP p1 (car ipL) (cadr ipL)))
               (setq p4 (car ipL))
           )
           (command "erase" (entlast) "")
           (command "move" ob "" p1 p3)
           (command "rotate" ob "" p3 (rtd (- (angle p3 p4) ag)))
           (setq p1 p3 ag (angle p3 p4))
           (command "delay" 100)
       )
   )
   (setq j (1+ j))
)
)
;;;===================MAIN====================
(defun C:MST( / ob p1 p2 cur pa1 pa2 st pL r ag j flag oldos p3 pa3 ipL p4)
(vl-load-com)
(prompt "Select objects will be moved...")
(setq
   ob (ssget)
   p1 (getpoint "\nFirst point (front):")
   p2 (getpoint "\nSecond point (back):")
   cur (car (entsel "\nSelect path:"))
   pa1 (vlax-curve-getParamAtPoint cur p1)
   pa2 (vlax-curve-getParamAtPoint cur p2)
)
(if (not (and pa1 pa2)) (progn (alert "1 or 2 points not on the path!") (exit)))
(setq
   st (getreal "\nStep:")
   pL (getpL cur st)
   r (distance p1 p2)
   ag (angle p1 p2)
   j 0
)
(if (> pa2 pa1) (progn (setq pL (reverse pL)) (setq flag -1)) (setq flag 1))
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(MoveStep)
(setvar "osmode" oldos)
(princ)
)
;;;===========================================
;;;NOTE
;;;Path is any types: line, pline, polygon, spline, circle, arc
;;;Objects: allow to select many objects that are any types (not block only) and lying anywhere
;;;But "First point" and "Second point" must be on the path
;;;I have tested with many cases, didn't find errors
;;;Positions of objects on the path are exact diametrically!
;;;But I think maybe it don't run correctly with some extraordinary curves