[编程交流] 沿直线移动直线/多段线

(defun c:MLTC (/ #SS #Curve #Int1 #Int2 #Pnt)
 ;; Move Lines to Curve; Alan J. Thompson, 03.16.10
 (vl-load-com)
 (cond
   ((and (princ "\nSelect Line object(s) to move: ")
         (setq #SS (ssget "_:L" '((0 . "LINE,LWPOLYLINE"))))
         (setq #Curve (car (entsel "\nSelect curve to move text to: ")))
         (or (vl-position (cdr (assoc 0 (entget #Curve))) '("LWPOLYLINE" "LINE" "ARC"))
             (alert "Invalid selected object!")
         ) ;_ or
         (setq #Curve (vlax-ename->vla-object #Curve))
    ) ;_ and
    (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
    (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
      (and (not (eq (vla-get-objectid x) (vla-get-objectid #Curve)))
           (setq #Int1 (vla-intersectwith x #Curve acextendthisentity))
           (setq #Int2 (vlax-safearray->list (vlax-variant-value #Int1)))
           (eq 3 (length #Int2))
           (setq #Pnt (car (vl-sort (list (vlax-curve-getstartpoint x) (vlax-curve-getendpoint x))
                                    '(lambda (a b) (< (distance a #Int2) (distance b #Int2)))
                           ) ;_ vl-sort
                      ) ;_ car
           ) ;_ setq
           (vla-move x (vlax-3d-point #Pnt) #Int1)
      ) ;_ and
    ) ;_ vlax-for
    (vla-delete #SS)
   )
 ) ;_ cond
 (princ)
) ;_ defun

(defun c:MLTC (/ ss obj int)
 ;; Move Lines to Curve
 ;; Required Subroutines: AT:GetSel
 ;; Alan J. Thompson, 03.16.10 / 08.02.10
 (vl-load-com)
 (if (and (princ "\nSelect line object(s) to move: ")
          (setq ss (ssget "_:L" '((0 . "LINE,LWPOLYLINE"))))
          (AT:GetSel entsel
                     "\nSelect curve to move line(s) to: "
                     (lambda (x)
                       (if (wcmatch (cdr (assoc 0 (entget (car x)))) "ARC,LINE,*POLYLINE,SPLINE")
                         (setq obj (vlax-ename->vla-object (car x)))
                       )
                     )
          )
     )
   ((lambda (id)
      (vlax-for x (setq
                    ss (vla-get-activeselectionset
                         (cond (*AcadDoc*)
                               ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
                         )
                       )
                  )
        (if (and (/= id (vla-get-objectid x))
                 (eq 3 (length (setq int (vlax-invoke x 'IntersectWith obj acExtendThisEntity))))
            )
          (vl-catch-all-apply
            (function vla-move)
            (list x
                  (vlax-3d-point
                    (car (vl-sort (list (vlax-curve-getStartPoint x) (vlax-curve-getEndPoint x))
                                  (function (lambda (a b) (< (distance a int) (distance b int))))
                         )
                    )
                  )
                  (vlax-3d-point int)
            )
          )
        )
      )
      (vla-delete ss)
    )
     (vla-get-objectid obj)
   )
 )
 (princ)
)
(defun AT:GetSel (meth msg fnc / ent good)
 ;; meth - selection method (entsel, nentsel, nentselp)
 ;; msg - message to display (nil for default)
 ;; fnc - optional function to apply to selected object
 ;; Ex: (AT:GetSel entsel "\nSelect arc: " (lambda (x) (eq (cdr (assoc 0 (entget (car x)))) "ARC")))
 ;; Alan J. Thompson, 05.25.10
 (setvar 'errno 0)
 (while (not good)
   (setq ent (meth (cond (msg)
                         ("\nSelect object: ")
                   )
             )
   )
   (cond
     ((vl-consp ent)
      (setq good (if (or (not fnc) (fnc ent))
                   ent
                   (prompt "\nInvalid object!")
                 )
      )
     )
     ((eq (type ent) 'STR) (setq good ent))
     ((setq good (eq 52 (getvar 'errno))) nil)
     ((eq 7 (getvar 'errno)) (setq good (prompt "\nMissed, try again.")))
   )
 )
)