[编程交流] Lisp绘制箭头

(defun c:Arrow (/ _group _dist lastentity p1 p2 ent obj gr coords pt)
 ;; Draw quick arrow
 ;; Alan J. Thompson, 03.13.11
 (defun _group (l)
   (if (caddr l)
     (cons (list (car l) (cadr l) (caddr l)) (_group (cdddr l)))
   )
 )
 (defun _dist (a b) (distance (list (car a) (cadr a)) (list (car b) (cadr b))))
 (setq lastentity (entlast))
 (if (and (setq p1 (getpoint "\nSpecify first point: "))
          (setq p2 (getpoint p1 "\nSpecity next point: "))
          (vl-cmdf "_.leader" "_non" p2 "_non" p1 "" "" "_N")
          (not (equal lastentity (setq ent (entlast))))
          (setq obj (vlax-ename->vla-object ent))
     )
   (while (eq 5 (car (setq gr (grread T 15 0))))
     (redraw)
     (grdraw (cadr gr)
             (trans (vlax-curve-getClosestPointTo ent (setq pt (trans (cadr gr) 1 0))) 0 1)
             3
             -1
     )
     (if
       (equal
         (last (setq coords (_group (vlax-get obj 'Coordinates))))
         (car (vl-sort coords (function (lambda (a b) (< (_dist a pt) (_dist b pt))))))
       )
        (vlax-put obj 'Coordinates (apply (function append) (reverse coords)))
     )
     (grdraw (cadr gr) (trans (car coords) 0 1) 1 -1)
   )
 )
 (redraw)
 (princ)
)
(defun c:ArrowM
      (/ _group _getPoints _arrow _closestpt AT:Arrow lastentity AT:Midpoint lst ent obj gr coords)
 ;; Draw Arrow
 ;; Alan J. Thompson, 03.13.11
 (defun _group (l)
   (if (caddr l)
     (cons (list (car l) (cadr l) (caddr l)) (_group (cdddr l)))
   )
 )
 (defun _getPoints (/ lst pt)
   (if (car (setq lst (list (getpoint "\nSpecify first point: "))))
     ((lambda (color)
        (while (setq pt (getpoint (car lst) "\nSpecify next point: "))
          (redraw)
          (mapcar (function (lambda (a b) (and a b (grdraw a b color -1))))
                  (setq lst (cons pt lst))
                  (cdr lst)
          )
          (AT:Arrow (car lst) (angle (cadr lst) (car lst)))
        )
        (redraw)
        lst
      )
       (cdr (assoc 62 (tblsearch "LAYER" (getvar 'CLAYER))))
     )
   )
 )
 (defun _arrow (lst)
   (mapcar
     (function
       (lambda (a b)
         (and a b (AT:Arrow (trans (AT:MidPoint a b) 0 1) (angle (trans b 0 1) (trans a 0 1))))
       )
     )
     lst
     (cdr lst)
   )
 )
 (defun _closestpt (lst p)
   (car (vl-sort lst (function (lambda (a b) (< (distance a p) (distance b p))))))
 )
 (defun AT:Arrow (#Location #Angle / #Size #Point1 #Point2 #Point3)
   ;; Display directional arrow
   ;; #Location - arrow placement point
   ;; #Angle - arrow directional angle
   ;; Alan J. Thompson, 04.28.09
   (setq #Size   (* (getvar "viewsize") 0.02)
         #Point1 (polar #Location #Angle #Size)
         #Point2 (polar #Location (+ #Angle (* pi 0.85)) #Size)
         #Point3 (polar #Location (+ #Angle (* pi 1.15)) #Size)
   )
   (grvecs (list 4 #Point1 #Point2 #Point2 #Point3 #Point3 #Point1))
   #Location
 )
 (defun AT:Midpoint (p1 p2)
   ;; Midpoint between two points
   ;; Alan J. Thompson, 04.23.09
   (mapcar (function (lambda (a b) (/ (+ a b) 2.))) p1 p2)
 )
 (setq lastentity (entlast))
 (if (and (setq lst (_getPoints))
          (progn (vl-cmdf "_.leader") (foreach p lst (vl-cmdf "_non" p)) (vl-cmdf "" "" "_N"))
          (not (equal lastentity (setq ent (entlast))))
          (setq obj (vlax-ename->vla-object ent))
     )
   (while (eq 5 (car (setq gr (grread T 15 0))))
     (redraw)
     (grdraw (cadr gr) (trans (vlax-curve-getClosestPointTo ent (trans (cadr gr) 1 0)) 0 1) 3 -1)
     (grdraw (cadr gr) (trans (car (setq coords (_group (vlax-get obj 'Coordinates)))) 0 1) 1 -1)
     (_arrow coords)
     (if (equal (last coords) (_closestpt coords (trans (cadr gr) 1 0)))
       (vlax-put obj 'Coordinates (apply (function append) (reverse coords)))
     )
   )
 )
 (redraw)
 (princ)
)

(defun c:arrow ( / di en gr l1 l2 nm p1 p2 )
   (if
       (and
           (setq p1 (getpoint "\n1st Point: "))
           (setq p2 (getpoint "\n2nd Point: " p1))
       )
       (progn
           (setq di (/ (distance p1 p2) 3.0)
                 nm (trans '(0. 0. 1.) 1 0 t)
           )
           (setq en
               (entget
                   (entmakex
                       (append
                           (list
                              '(0 . "LWPOLYLINE")
                              '(100 . "AcDbEntity")
                              '(100 . "AcDbPolyline")
                              '(90 . 3)
                              '(70 . 0)
                           )
                           (setq l1
                               (list
                                   (cons 10 (trans p1 1 nm))
                                   (cons 10 (trans (polar p2 (angle p2 p1) di) 1 nm))
                                   (cons 40 (/ di 2.0))
                                  '(41 . 0.0)
                                   (cons 10 (trans p2 1 nm))
                                   (cons 210 nm)
                               )
                           )
                       )
                   )
               )
           )
           (setq l2
               (list
                   (cons 10 (trans p1 1 nm))
                  '(40 . 0.0)
                   (cons 41 (/ di 2.0))
                   (cons 10 (trans (polar p1 (angle p1 p2) di) 1 nm))
                   (cons 10 (trans p2 1 nm))
                   (cons 210 nm)
               )
           )
           (setq en (reverse (member (assoc 39 en) (reverse en))))
           (princ "\nChoose Arrow End...")
           (while (= 5 (car (setq gr (grread t 13 0))))
               (entmod
                   (append en
                       (if (< (distance (cadr gr) p2) (distance (cadr gr) p1)) l1 l2)
                   )
               )
           )
       )                    
   )
   (princ)
)

6