[编程交流] 引线起点

(defun c:Backwards_Leader (/ *error* GetPoints ENT OBJ PTLST UFLAG)
 (vl-load-com)
 ;; Lee Mac  ~  05.03.10
 (setq *doc (cond (*doc) ((vla-get-ActiveDocument
                            (vlax-get-acad-object)))))
 (defun *error* (msg)
   (and uFlag (vla-EndUndoMark *doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (redraw) (princ))
 
 (defun GetPoints (/ lst pt)
   (if (car (setq lst (list (getpoint "\nPick First Point: "))))
     (while (setq pt (getpoint "\nPick Next Point: " (car lst)))
       (mapcar
         (function
           (lambda (from to)
             (grdraw from to 40 1)))
         (cdr (reverse (setq lst (cons pt lst))))
         (reverse (cdr lst)))))
   
    lst)
 (while
   (progn
     (setq ent (car (entsel "\nSelect Text for Leader: ")))
     (cond (  (eq 'ENAME (type ent))
              (if (eq (vla-get-ObjectName
                        (setq obj (vlax-ename->vla-object ent))) "AcDbMText")
                (if (setq ptLst (GetPoints))
                  (progn
                    (setq uFlag (not (vla-StartUndoMark *doc)))
                    (vla-AddLeader
                      
                      (if (eq AcPaperSpace (vla-get-ActiveSpace *doc))
                        (if (eq :vlax-true (vla-get-MSpace *doc))
                          (vla-get-ModelSpace *doc)
                          (vla-get-PaperSpace *doc))
                        (vla-get-ModelSpace *doc))
                      
                      (variant
                        (vlax-safearray-fill
                          (safearray vlax-vbDouble
                            (cons 0 (1- (* 3 (length ptLst)))))                           
                          (apply (function append) ptLst)))
                      
                      obj acLineWithArrow)
                    (setq uFlag (vla-EndUndoMark *doc))))
                (princ "\n** Object Must be MText **"))))))
 
 (redraw) (princ))

(defun c:drleader()
(setq MS (vla-get-ModelSpace (vla-get-activeDocument (vlax-get-acad-object)) ))
(setq p1 (getpoint "\n Getpoint p1 :"))
(setq p2 (getpoint p1 "\n Getpoint p2 :"))
(setq lst (append p1 p2))
(setq vri (vlax-make-variant
      (vlax-safearray-fill
  (vlax-make-safearray vlax-VBDouble 
          (cons 1 (length lst))
  )
         lst)
  )
)
(vla-addleader MS vri nil acLineNoArrow)
(princ)
)