[编程交流] 多个偏移

(defun c:cl (/ _Mid ss i sn e1 e2 p1 p2 p3 p4)
 (defun *error* (x) (princ "\n *Cancel*"))
 (if
   (eq
     4
     (logand 4
             (cdr
               (assoc 70 (entget (tblobjname "LAYER" (getvar 'clayer))))
             )
     )
   )
    (progn
      (alert "<!> Current layer is LOCKED <!>")
      (exit)
    )
 )
 (defun _Mid (pt1 pt2)
   (mapcar (function (lambda (j k) (* (+ j k) 0.5))) pt1 pt2)
 )
 (if (and (setq ss (ssget "_:L" '((0 . "LINE"))))
          (if (eq 2 (setq i (sslength ss)))
            t
            (progn
              (alert "Please select only two lines , OKAY ? ")
              nil
            )
          )
     )
   (progn
     (setq e1 (entget (ssname ss 0))
           e2 (entget (ssname ss 1))
           p1 (cdr (assoc 10 e1))
           p2 (cdr (assoc 11 e1))
           p3 (cdr (assoc 10 e2))
           p4 (cdr (assoc 11 e2))
     )
     (if (not (inters p1 p3 p2 p4))
       (entmakex (list '(0 . "LINE")
                       (cons 10 (_Mid p1 p3))
                       (cons 11 (_Mid p2 p4))
                 )
       )
       (entmakex (list '(0 . "LINE")
                       (cons 10 (_Mid p1 p2))
                       (cons 11 (_Mid p3 p4))
                 )
       )
     )
   )
 )
 (princ "\n Written By Tharwat Al Shoufi")
 (princ)
)

(defun c:LBL (/ foo AT:GetSel _pnts _pline _lwpline _dist e1 e2)
 ;; Draw (LW)Polyline between two selected curves (at midpoint of vertices).
 ;; Alan J. Thompson, 09.29.10
 (vl-load-com)
 (defun foo (e)
   (and (wcmatch (cdr (assoc 0 (entget (car e)))) "LINE,*POLYLINE,SPLINE")
        (not (vlax-curve-isClosed (car e)))
   )
 )
 (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
   (while
     (progn (setvar 'ERRNO 0)
            (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
 )
 (defun _pnts (e / p l)
   (if e
     (cond ((wcmatch (cdr (assoc 0 (entget e))) "ARC,LINE,SPLINE")
            (list (vlax-curve-getStartPoint e) (vlax-curve-getEndPoint e))
           )
           ((wcmatch (cdr (assoc 0 (entget e))) "*POLYLINE")
            (repeat (setq p (1+ (fix (vlax-curve-getEndParam e))))
              (setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l))
            )
           )
     )
   )
 )
 (defun _pline (lst)
   (if (and (> (length lst) 1)
            (entmakex '((0 . "POLYLINE") (10 0. 0. 0.) (70 . ))
            (foreach x lst (entmakex (list '(0 . "VERTEX") (cons 10 x) '(70 . 32))))
       )
     (cdr (assoc 330 (entget (entmakex '((0 . "SEQEND"))))))
   )
 )
 (defun _lwpline (lst)
   (if (> (length lst) 1)
     (entmakex (append
                 (list '(0 . "LWPOLYLINE")
                       '(100 . "AcDbEntity")
                       '(100 . "AcDbPolyline")
                       (cons 90 (length lst))
                       (cons 70 (* (getvar 'plinegen) 128))
                 )
                 (mapcar (function (lambda (p) (list 10 (car p) (cadr p)))) lst)
               )
     )
   )
 )
 (defun _dist (a b) (distance (list (car a) (cadr a)) (list (car b) (cadr b))))
 (if
   (and
     (setq e1 (_pnts (car (AT:GetSel entsel "\nSelect first open curve: " foo))))
     (setq e2 (_pnts (car (AT:GetSel entsel "\nSelect next open curve: " foo))))
     (not (initget 0 "Lwpolyline Polyline"))
     (setq *LBL:Opt* (cond ((getkword (strcat "\nSpecify line to draw: [Lwpolyline/Polyline] <"
                                              (cond (*LBL:Opt*)
                                                    ((setq *LBL:Opt* "Lwpolyline"))
                                              )
                                              ">: "
                                      )
                            )
                           )
                           (*LBL:Opt*)
                     )
     )
   )
    ((if (eq *LBL:Opt* "Lwpolyline")
       _lwpline
       _pline
     )
      (vl-remove nil
                 (mapcar (function (lambda (a b)
                                     (if (and a b (not (grdraw (trans a 0 1) (trans b 0 1) 1 1)))
                                       (mapcar (function (lambda (a b) (/ (+ a b) 2.))) a b)
                                     )
                                   )
                         )
                         e1
                         (if (< (_dist (car e1) (car e2))
                                (_dist (car e1) (last e2))
                             )
                           e2
                           (reverse e2)
                         )
                 )
      )
    )
 )
 (princ)
)