[编程交流] 移动线，对齐边缘

(defun c:MLTC2 (/ 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.")))
   )
 )
)

(defun c:MCTC (/ _1st AT:GetSel ss obj int)
 (vl-load-com)
 (defun _1st (lst)
   (if lst
     (list (car lst) (cadr lst) (caddr lst))
   )
 )
 (defun AT:GetSel (meth msg fnc / ent)
   ;; 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
     (progn (setq ent (meth (cond (msg)
                                  ("\nSelect object: ")
                            )
                      )
            )
            (cond ((eq (getvar 'ERRNO) 7) (princ "\nMissed, try again."))
                  ((eq (type (car ent)) 'ENAME)
                   (if (and fnc (not (fnc ent)))
                     (princ "\nInvalid object!")
                   )
                  )
            )
     )
   )
   ent
 )
 (princ "\nSelect curve object(s) to move: ")
 (if (and (setq ss (ssget "_:L" '((0 . "LINE,LWPOLYLINE"))))
          (AT:GetSel entsel
                     "\nSelect curve to move selected curve(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 (/= (vla-get-objectid x) id)
                 (setq int (_1st (vlax-invoke x 'IntersectWith obj acExtendThisEntity)))
            )
          (vla-move 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)
)

;; Example program by Lee Mac 2011  -  www.lee-mac.com
(defun c:MoveLines2Line ( / en in ip p1 p2 p3 p4 ss )
   (if
       (and
           (princ "\nSelect Line to Move Lines to...")
           (setq en (ssget "_+.:E:S" '((0 . "LINE"))))
           (princ "\nSelect Lines to Move...")
           (setq ss (ssget "_:L" '((0 . "LINE"))))
       )
       (progn
           (setq en (entget (ssname en 0))
                 p1 (cdr (assoc 10 en))
                 p2 (cdr (assoc 11 en))
           )
           (repeat (setq in (sslength ss))
               (setq en (entget (ssname ss (setq in (1- in))))
                     p3 (cdr (assoc 10 en))
                     p4 (cdr (assoc 11 en))
               )
               (if (setq ip (inters p1 p2 p3 p4 nil))
                   (entmod
                       (cons (assoc -1 en)
                           (if (< (distance ip p4) (distance ip p3))
                               (list
                                   (cons 11 ip)
                                   (cons 10 (mapcar '+ ip (mapcar '- p3 p4)))
                               )
                               (list
                                   (cons 10 ip)
                                   (cons 11 (mapcar '+ ip (mapcar '- p4 p3)))
                               )
                           )
                       )
                   )
               )
           )
       )
   )
   (princ)
)

(defun c:LinesTo ( / M o v e to edge)
(defun _errorMsg  (lst / NilVal)
      (while (eval (setq NilVal (car (car lst))))
            (setq lst (cdr lst)))
      (if lst
            (alert (cadr (assoc NilVal lst))))
      )
(prompt "\nSelect objects to move: ")
     (cond ((and
     (setq M (ssget ":L" '((0 . "LINE"))))
     (setq o (car (entsel "\nSelect Edge: ")))
     (setq o (vlax-ename->vla-object o))
     (repeat (sslength M)
           (setq v (ssname M 0))
 (setq edge (mapcar 'cdr (vl-remove-if-not '(lambda (y)
                               (member (car y) '(10 11))) (entget v))))
            (setq e (vlax-invoke (vlax-ename->vla-object v) 'IntersectWith  o acExtendThisEntity))
            (if e (progn
                (if (> (distance e (cadr edge))
                       (distance e (car edge)))
                     (setq to (car edge))
                 (setq to (cadr edge))
                    )
             (vla-move (vlax-ename->vla-object v)
                      (vlax-3d-point to)(vlax-3d-point e))
                       )
                   (progn
                   (princ "\rNo Intersection Found for ")(prin1 ent) ))
            (ssdel v M))
       )
            )
           )
     (_errorMsg
      (list '(m "Failed to select Object")
            '(o "Edge Not Found")
                       ))
(princ)
     )