[编程交流] Lisp程序问题，请用l

;;http://bbs.xdcad.org/thread-678248-1-1.html
;;by huang
(defun C:myjoin(/ E H J LST N OBJ P11 P12 P21 P22 SS X)
 (defun twoEnt        (e1 e2)
   (setq p11 (vlax-curve-getStartPoint e1))
   (setq p12 (vlax-curve-getEndPoint e1))
   (setq p21 (vlax-curve-getStartPoint e2))
   (setq p22 (vlax-curve-getEndPoint e2))
   (cond ((and (equal (det p11 p12 p21) 0) (equal (det p11 p12 p22) 0))
   (setq H (car (Max-distance (list p11 p12 p21 p22))))
   (setq obj (vlax-ename->vla-object e1))
   (vlax-put obj 'StartPoint (car H))
   (vlax-put obj 'EndPoint (cadr H))
  )
   )
 )
 (cond
   ((setq ss (ssget '((0 . "LINE"))))
    (repeat (setq n (sslength ss))
      (setq e (ssname ss (setq n (1- n))))
      (setq lst (cons e lst))
    )
    (foreach j        lst
      (mapcar '(lambda (x) (cond ((and (entget x) (entget j)) (twoEnt j x)))) lst)
    )
   )
 )
 (princ)
)
;;(Max-distance (getpt (ssget) 10))=>(((-2670.87 3701.22 0.0) (-1725.61 3689.13 0.0)) . 945.338)
(defun Max-distance (H / D M MAXD P PAIR Q U V W)
 (setq Q (cdr (append H H (list (car H)))))                   
 (setq MaxD 0.0)                                            
 (foreach U H                                                    
   (setq V (car Q))                                           
   (setq W (cadr Q))                                           
   (setq M (MJ:Mid V W))                                    
   (while (> (dot M U V) 0.0)                                    
     (setq Q (cdr Q))                                           
     (setq V (car Q))                                           
     (setq W (cadr Q))                                           
     (setq M (MJ:Mid V W))                                    
   )
   (setq D (distance U V))                                   
   (if        (> D MaxD)                                            
     (setq MaxD D                                           
    Pair (list U V)                                    
     )
   )
 )
 (cons Pair MaxD)                                           
)
(defun MJ:Mid (P1 P2)
 (mapcar '(lambda (X Y) (* (+ X Y) 0.5)) P1 P2)
)
;;(det (getpoint)(getpoint)(getpoint))
(defun det (p1 p2 p3 / x2 y2)
 (setq        x2 (car p2)
       y2 (cadr p2)
 )
 (- (* (- x2 (car p3)) (- y2 (cadr p1)))
    (* (- x2 (car p1)) (- y2 (cadr p3)))
 )
)

;;http://bbs.xdcad.org/thread-678248-1-1.html
;;by huang
;;mod by M.R.
(defun c:myjoin (/ e h j lst n obj p11 p12 p21 p22 ss)
 (vl-load-com)
 (defun twoent (e1 e2)
   (setq p11 (vlax-curve-getstartpoint e1))
   (setq p12 (vlax-curve-getendpoint e1))
   (setq p21 (vlax-curve-getstartpoint e2))
   (setq p22 (vlax-curve-getendpoint e2))
   (if (and (equal (det p11 p12 p21) 0)
            (equal (det p11 p12 p22) 0)
       )
 [highlight];=> if you want only WCS calculation leave this line, but if you want it 3D replace line with T[/highlight]
     (progn
       (setq h (car (max-distance (list p11 p12 p21 p22))))
       (setq obj (vlax-ename->vla-object e1))
       (vlax-put obj 'startpoint (car h))
       (vlax-put obj 'endpoint (cadr h))
     )
   )
 )
 (cond
   ((setq ss (ssget '((0 . "LINE"))))
    (repeat (setq n (sslength ss))
      (setq e (ssname ss (setq n (1- n))))
      (setq lst (cons e lst))
    )
    (foreach j lst
      (mapcar '(lambda (x)
                 (cond ((and (entget x) (entget j)) (twoent j x)))
               )
              lst
      )
    )
   )
 )
 (princ)
)
;;(max-distance ptlst)=>(((-2670.87 3701.22 0.0) (-1725.61 3689.13 0.0)) . 945.338)
(defun max-distance (h / d maxd pair q v)
 (setq q (cdr (append h h (list (car h)))))
 (setq maxd 0.0)
 (foreach u h
   (setq
     v (car
         (vl-sort q
                  '(lambda (a b) (> (distance u a) (distance u b)))
         )
       )
   )
   (setq d (distance u v))
   (if (> d maxd)
     (setq maxd d
           pair (list u v)
     )
   )
 )
 (cons pair maxd)
)
;;(det (getpoint)(getpoint)(getpoint))
(defun det (p1 p2 p3)
 (+ (* (car p1)
       (- (* (cadr p2) (caddr p3)) (* (cadr p3) (caddr p2)))
    )
    (* (- (cadr p1))
       (- (* (car p2) (caddr p3)) (* (car p3) (caddr p2)))
    )
    (* (caddr p1)
       (- (* (car p2) (cadr p3)) (* (car p3) (cadr p2)))
    )
 )
)

(defun dot (p1 p2 p3 / x1 y1)
 (setq        x1 (car p1)
       y1 (cadr p1)
 )
 (+ (* (- (car p2) x1) (- (car p3) x1))
    (* (- (cadr p2) y1) (- (cadr p3) y1))
 )
)

;Written by: Chris Wade
;small mod by M.R.
(defun c:ja ( / *error* uFlag doc StopLoop SelSet SelLen LoopCT )
 (vl-load-com)
 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (defun *error* (msg)
   (if doc
     (vla-EndUndoMark doc)
   )
   (if msg
     (prompt msg)
   )
   (princ)
 )
 (while (= StopLoop nil)
   (princ
     "\nPlease select the objects that you would like to join : "
   )
   (setq SelSet (ssget))
   (cond ((/= SelSet nil)
          (vla-StartUndoMark doc)
          (setq SelLen (sslength SelSet))
          (setq LoopCT 0)
          (while (< LoopCT SelLen)
            (vl-cmdf "._join" (ssname SelSet LoopCT) SelSet "")
            (setq LoopCT (+ LoopCT 1))
          )
          (setq StopLoop T)
         )
   )
 )
 (*error* nil)
)

;;by M.R.
(defun c:myjoin ( / max-distance e ptlst n p1 p2 ss filter ch x )
 ;;(max-distance ptlst)=>(((-2670.87 3701.22 0.0) (-1725.61 3689.13 0.0)) . 945.338)
 (defun max-distance ( h / d maxd pair q v )
   (setq q h)
   (setq maxd 0.0)
   (foreach u h
     (setq
       v (car
           (vl-sort q
                    '(lambda ( a b ) (> (distance u a) (distance u b)))
           )
         )
     )
     (setq d (distance u v))
     (if (> d maxd)
       (setq maxd d
             pair (list u v)
       )
     )
   )
   (cons pair maxd)
 )
 (initget "2D 3D")
 (setq ch (getkword "\n2D or 3D calculation [2D/3D] <3D> : "))
 (if (null ch)
   (setq ch "3D")
 )
 (setq filter (if (eq ch "3D")
                (list '(0 . "LINE"))
                (list '(0 . "LINE")          '(-4 . "<and")
                      '(-4 . "*,*,=")        '(10 0.0 0.0 0.0)
                      '(-4 . "*,*,=")        '(11 0.0 0.0 0.0)
                      '(-4 . "and>")
                     )
              )
 )
 (setq ss (ssget filter))
 (repeat (setq n (sslength ss))
   (setq e (ssname ss (setq n (1- n))))
   (setq p1 (cdr (assoc 10 (entget e)))
         p2 (cdr (assoc 11 (entget e)))
   )
   (setq ptlst (cons p1 ptlst)
         ptlst (cons p2 ptlst)
   )
 )
 (setq x (max-distance ptlst))
 (entmake (list '(0 . "LINE")
                (cons 10 (caar x))
                (cons 11 (cadar x))
                '(62 . 1)
          )
 )
 (princ)
)