[编程交流] 距离最近Po的区块距离

(defun c:pdis(/ cCurve cBlock dPt1 dPt2)
 (vl-load-com)
 (if
   (and
     (setq cCurve(entsel "\nSelect curve to measure > "))
     (member(cdr(assoc 0(entget(car cCurve))))
     '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE" "ARC" "CIRCLE" "ELLIPSE"))
     ); end and
     (while
       (and
  (setq cBlock(entsel "\nSelect block or Esc to Quit > "))
  (=(cdr(assoc 0(entget(car cBlock)))) "INSERT")
  ); end and
(progn
    (setq dPt1(cdr(assoc 10(entget(car cBlock))))
          dPt2(vlax-curve-getClosestPointTo (car cCurve) dPt1))
    (vl-cmdf "_.dimaligned" (trans dPt1 0 1) (trans dPt2 0 1) pause)
  ); end progn
(princ "\n<!> Empty selection or this isn't block <!> ")
); end while
   (princ "\n<!> Empty selection or this isn't curve (line, polyline, etc.) <!> ")
   ); end if
 (princ)
 ); end of c:pdis

;=======================================================================
;    ClosePT.Lsp                                    Jan 08, 2009
;    Find Thge Closest Point From An INSERT to a PATH - 2D
;================== Start Program ======================================
(princ "\nCopyright (C) 1990-2009, Fabricated Designs, Inc.")
(princ "\nLoading ClosePT v1.0")
(setq cpt_ nil lsp_file "ClosePT")
;++++++++++++ Set Modes & Error ++++++++++++++++++++++++++++++++++
(defun cpt_smd ()
(SetUndo)
(setq olderr *error*
     *error* (lambda (e)
               (while (> (getvar "CMDACTIVE") 0)
                      (command))
               (and (/= e "quit / exit abort")
                    (princ (strcat "\nError: *** " e " *** ")))
               (and (= (logand (getvar "UNDOCTL")  8)
                    (command "_.UNDO" "_END" "_.U"))
               (cpt_rmd))
      cpt_var '(("CMDECHO"   . 0) ("MENUECHO"   . 0)
               ("MENUCTL"   . 0) ("MACROTRACE" . 0)
               ("OSMODE"    . 0) ("SORTENTS"   . 119)
               ("LUPREC"    . 2)
               ("BLIPMODE"  . 0) ("EXPERT"     . 0)
               ("SNAPMODE"  . 1) ("PLINEWID"   . 0)
               ("ORTHOMODE" . 1) ("GRIDMODE"   . 0)
               ("ELEVATION" . 0) ("THICKNESS"  . 0)
               ("COORDS"    . 2) ("UCSICON"    . 1)
               ("HIGHLIGHT" . 1) ("REGENMODE"  . 1)
               ("CECOLOR"   . "BYLAYER")
               ("CELTYPE"   . "BYLAYER")))
(foreach v cpt_var
  (and (getvar (car v))
       (setq cpt_rst (cons (cons (car v) (getvar (car v))) cpt_rst))
       (setvar (car v) (cdr v))))
(princ (strcat (getvar "PLATFORM") " Release " (ver)))
(princ))
;++++++++++++ Return Modes & Error +++++++++++++++++++++++++++++++
(defun cpt_rmd ()
 (setq *error* olderr)
 (foreach v cpt_rst (setvar (car v) (cdr v)))
 (command "_.UNDO" "_END")
 (prin1))
;++++++++++++ Set And Start An Undo Group ++++++++++++++++++++++++
(defun SetUndo ()
(and (zerop (getvar "UNDOCTL"))
     (command "_.UNDO" "_ALL"))
(and (= (logand (getvar "UNDOCTL") 2) 2)
     (command "_.UNDO" "_CONTROL" "_ALL"))
(and (= (logand (getvar "UNDOCTL")  8)
     (command "_.UNDO" "_END"))
(command "_.UNDO" "_GROUP"))
;;;++++++++++ 2D Is Point On ARC ++++++++++++++++++++++++++++++++++++++
;;;ARG -> ARC_Ename  TestPoint  Fuzz
;;;RET -> T nil
(defun is_pt_on_arc (en tp fz / ed ce ra sa ea ta)
  (setq ed (entget en)
        ce (p2d (cdr (assoc 10 ed)))
        ra (cdr (assoc 40 ed))
        sa (cdr (assoc 50 ed))
        ea (cdr (assoc 51 ed))
        ta (angle ce tp)
        tp (p2d tp))
  (and (equal (distance ce tp) ra fz)
       (if (> sa ea)
           (or (>= ta sa)
               (<= ta ea))
           (and (<= ta ea)
                (>= ta sa)))))
;;;++++++++++ 2D Intersections Of Line & Arc ( Circle ) ++++++++++++++++
;;;ARG -> LINE_ename ARC_ename ( CIRCLE or ARC )
;;;RET -> nil or List_Of_Points
;;;ERROR = None
(defun inter_line_arc (l10 l11 arc / a10 rad ip1 ip2)
(setq l10 (p2d l10)
     l11 (p2d l11)
     a10 (p2d (cdr (assoc 10 (entget arc))))
     rad (cdr (assoc 40 (entget arc)))
     ip1 (polar a10 (angle l10 l11) rad)
     ip2 (polar a10 (angle l11 l10) rad))
(cond ((is_pt_on_arc arc ip1 1e-
      ip1)
     ((is_pt_on_arc arc ip2 1e-
      ip2)))
;;;FIND CLOSEST POINT TO LINE FORM GIVEN POINT
;;;ARG -> POINT LINE_ENAME
;;;RET -> POINT
(defun find_near_line (p l / ld l10 l11 tp)
 (setq ld (entget l)
       l10 (p2d (cdr (assoc 10 ld)))
       l11 (p2d (cdr (assoc 11 ld)))
         p (p2d p))
 (cond ((setq tp (inters l10 l11
                         p (polar p (+ (angle l10 l11) (* pi 0.5)) 1))))
       ((if (< (distance p l10)
               (distance p l11))
            (setq tp l10)
            (setq tp l11))))
tp)
;************ Main Program ***************************************
(defun cpt_ (/ olderr cpt_var cpt_rst ss bn bp ls pn pd pf fe fd pc ts
             cp np p2d)
 (cpt_smd)
 (setq p2d (lambda (p) (list (car p) (cadr p))))
 (while (or (not ss)
            (> (sslength ss) 1))
        (princ "\nSelect Block To Test:   ")
        (setq ss (ssget (list (cons 0 "INSERT")
                              (if (getvar "CTAB")
                                  (cons 410 (getvar "CTAB"))
                                  (cons 67 (- 1 (getvar "TILEMODE"))))))))
 (setq bn (ssname ss 0)
       bp (p2d (trans (cdr (assoc 10 (entget bn))) bn 0)))
 (while (or (not ls)
            (> (sslength ls) 1))
        (princ "\nSelect Path To Test:   ")
        (setq ls (ssget (list (cons 0 "LINE,*POLYLINE")
                              (if (getvar "CTAB")
                                  (cons 410 (getvar "CTAB"))
                                  (cons 67 (- 1 (getvar "TILEMODE")))))))
        (and ls
          (setq pn (ssname ls 0)
                pd (entget pn)
                pf (cdr (assoc 70 pd)))
          (= "POLYLINE" (cdr (assoc 0 pd)))
          (> pf 15)
          (princ "\nPOLYLINE MESHES CANNOT BE USED")
          (setq ls nil)))
 (command "_.COPY" pn "" '(0 0 0) '(0 0 0))
 (setq pc (entlast) fe pc)
 (command "_.EXPLODE" pc)
 (setq fe (entnext fe)
       ts (ssadd))
 (while fe
      (ssadd fe ts)
      (setq fd (entget fe))
      (cond ((= "LINE" (cdr (assoc 0 fd)))
             (setq np (find_near_line bp fe)))
            ((= "ARC" (cdr (assoc 0 fd)))
             (setq np (inter_line_arc bp (cdr (assoc 10 fd)) fe))))
      (cond ((not np))
            ((not cp)
             (setq cp np))
            (T
             (setq cp (if (> (distance cp bp)
                             (distance np bp))
                       np cp))))
      (setq fe (entnext fe)))
 (command "_.ERASE" pc ts "")
 (redraw)
 (princ "\nClosest Point in 2D From Block To Path Is ")
 (prin1 cp)
 (cpt_rmd))
;************ Load Program ***************************************
(defun C:ClosePT () (cpt_))
(if cpt_ (princ "\nClosePT Loaded\n"))
(prin1)
;|================== End Program =======================================