[编程交流] 两个相交点之间的距离

(defun c:int_dist (/ *error* isCurveObj ss->list vlax-list->3D-point SortFromPt SortbyParam
                    DIST ENT ILST LANG MA MI MPT OBJ PT SS TOBJ UFLAG X Y
                  )
 (vl-load-com)
 ;; Lee Mac  ~  04.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 " **"))
   ) ;_  or
   (princ)
 ) ;_  defun
 (defun isCurveObj (ent)
   (not
     (vl-catch-all-error-p
       (vl-catch-all-apply
         (function
           vlax-curve-getEndParam
         ) ;_  function
         (list ent)
       ) ;_  vl-catch-all-apply
     ) ;_  vl-catch-all-error-p
   ) ;_  not
 ) ;_  defun
 (defun ss->list (ss / i ent ObjLst)
   (setq i -1)
   (while (setq ent (ssname ss (setq i (1+ i))))
     (setq ObjLst
            (cons
              (vlax-ename->vla-object ent)
              Objlst
            ) ;_  cons
     ) ;_  setq
   ) ;_  while
   ObjLst
 ) ;_  defun
 (defun vlax-list->3D-point (lst)
   (if lst
     (cons (list (car lst) (cadr lst) (caddr lst))
           (vlax-list->3D-point (cdddr lst))
     ) ;_  cons
   ) ;_  if
 ) ;_  defun
 (defun SortFromPt (pt lst)
   (vl-sort lst
            (function
              (lambda (a b)
                (< (distance a pt)
                   (distance b pt)
                ) ;_  <
              ) ;_  lambda
            ) ;_  function
   ) ;_  vl-sort
 ) ;_  defun
 (defun SortByParam (ent lst)
   (vl-sort lst
            (function
              (lambda (a b)
                (< (vlax-curve-getParamatPoint
                     ent
                     a
                   ) ;_  vlax-curve-getParamatPoint
                   (vlax-curve-getParamatPoint
                     ent
                     b
                   ) ;_  vlax-curve-getParamatPoint
                ) ;_  <
              ) ;_  lambda
            ) ;_  function
   ) ;_  vl-sort
 ) ;_  defun
 (while
   (progn
     (setq ent (car (entsel)))
     (cond ((eq 'ENAME (type ent))
            (if (isCurveObj ent)
              (progn
                (vla-getBoundingBox
                  (setq obj
                         (vlax-ename->vla-object ent)
                  ) ;_  setq
                  'Mi
                  'Ma
                ) ;_  vla-getBoundingBox
                (mapcar
                  (function set)
                  '(Mi Ma)
                  (mapcar
                    (function
                      vlax-safearray->list
                    ) ;_  function
                    (list Mi Ma)
                  ) ;_  mapcar
                ) ;_  mapcar
                (setq ss
                       (ssget "_C"
                              (list (car Mi) (cadr Ma) 0.)
                              (list (car Ma) (cadr Mi) 0.)
                       ) ;_  ssget
                ) ;_  setq
                (if
                  (and
                    (setq iLst
                           (apply
                             (function
                               append
                             ) ;_  function
                             (vl-remove 'nil
                                        (mapcar
                                          (function
                                            (lambda (x)
                                              (vlax-list->3D-point
                                                (vlax-invoke
                                                  obj
                                                  'IntersectWith
                                                  x
                                                  acExtendNone
                                                ) ;_  vlax-invoke
                                              ) ;_  vlax-list->3D-point
                                            ) ;_  lambda
                                          ) ;_  function
                                          (ss->list
                                            (ssdel ent ss)
                                          ) ;_  ss->list
                                        ) ;_  mapcar
                             ) ;_  vl-remove
                           ) ;_  apply
                    ) ;_  setq
                    (< 1 (length iLst))
                  ) ;_  and
                   (progn
                     (setq uFlag
                            (not
                              (vla-StartUndoMark *doc)
                            ) ;_  not
                     ) ;_  setq
                     (setq iLst (SortByParam
                                  ent
                                  iLst
                                ) ;_  SortFromPt
                     ) ;_  setq
                     (or
                       (equal
                         (vlax-curve-getStartParam ent)
                         (vlax-curve-getParamatPoint
                           ent
                           (car iLst)
                         ) ;_  vlax-curve-getParamatPoint
                         0.001
                       ) ;_  equal
                       (setq iLst
                              (cons
                                (vlax-curve-getStartPoint ent)
                                iLst
                              ) ;_  cons
                       ) ;_  setq
                     ) ;_  or
                     (or
                       (equal
                         (vlax-curve-getEndParam ent)
                         (vlax-curve-getParamatPoint
                           ent
                           (last iLst)
                         ) ;_  vlax-curve-getParamatPoint
                         0.001
                       ) ;_  equal
                       (setq iLst
                              (append iLst
                                      (list
                                        (vlax-curve-getEndPoint ent)
                                      ) ;_  list
                              ) ;_  append
                       ) ;_  setq
                     ) ;_  or
                     (while
                       (cadr iLst)
                        (setq x (car iLst)
                              y (cadr iLst)
                        ) ;_  setq
                        (setq mPt
                               (vlax-curve-getPointatDist
                                 ent
                                 (/
                                   (+
                                     (vlax-curve-getDistatPoint
                                       ent
                                       y
                                     ) ;_  vlax-curve-getDistatPoint
                                     (vlax-curve-getDistAtPoint
                                       ent
                                       x
                                     ) ;_  vlax-curve-getDistAtPoint
                                   ) ;_  -
                                   2.
                                 ) ;_  /
                               ) ;_  vlax-curve-getPointatDist
                        ) ;_  setq
                        (setq dist
                               (abs
                                 (-
                                   (vlax-curve-getDistatPoint
                                     ent
                                     y
                                   ) ;_  vlax-curve-getDistatPoint
                                   (vlax-curve-getDistAtPoint
                                     ent
                                     x
                                   ) ;_  vlax-curve-getDistAtPoint
                                 ) ;_  -
                               ) ;_  abs
                        ) ;_  setq
                        (setq lAng
                               (angle '(0 0 0)
                                      (vlax-curve-getFirstDeriv
                                        ent
                                        (vlax-curve-getParamatPoint
                                          ent
                                          mPt
                                        ) ;_  vlax-curve-getParamatPoint
                                      ) ;_  vlax-curve-getFirstDeriv
                               ) ;_  angle
                        ) ;_  setq
                        (cond ((and (> lAng (/ pi 2)) (<= lAng pi))
                               (setq lAng (- lAng pi))
                              )
                              ((and (> lAng pi) (<= lAng (/ (* 3 pi) 2)))
                               (setq lAng (+ lAng pi))
                              )
                        ) ;_  cond
                        (setq tObj
                               (vla-AddText
                                 (if
                                   (zerop
                                     (vla-get-ActiveSpace *doc)
                                   ) ;_  zerop
                                    (if
                                      (eq :vlax-true
                                          (vla-get-MSpace *doc_)
                                      ) ;_  eq
                                       (vla-get-ModelSpace *doc)
                                       (vla-get-PaperSpace *doc)
                                    ) ;_  if
                                    (vla-get-ModelSpace *doc)
                                 ) ;_  if
                                 (rtos dist)
                                 (vlax-3D-point
                                   '(0 0 0)
                                 ) ;_  vlax-3D-point
                                 (getvar 'TEXTSIZE)
                               ) ;_  vla-AddText
                        ) ;_  setq
                        (vla-put-Alignment tObj acAlignmentMiddleCenter)
                        (vla-put-TextAlignmentPoint
                          tObj
                          (vlax-3D-point
                            (polar mPt
                                   (+ lAng (/ pi 2.))
                                   (getvar 'TEXTSIZE)
                            ) ;_  polar
                          ) ;_  vlax-3D-point
                        ) ;_  vla-put-TextAlignmentPoint
                        (vla-put-rotation tObj lAng)
                        (setq iLst (cdr iLst))
                     ) ;_  while
                     (setq uFlag
                            (vla-EndUndomark *doc)
                     ) ;_  setq
                   ) ;_  progn
                   (princ "\n** Object Has less than Two Intersections **")
                ) ;_  if
              ) ;_  progn
              (princ "\n** Invalid Object Selected **")
            ) ;_  if
           )
     ) ;_  cond
   ) ;_  progn
 ) ;_  while
 (princ)
) ;_  defun

(or *doc (setq *doc (vla-get-activedocument (vlax-get-acad-object))))

(* (/ 1 (getvar 'cannoscalevalue)) (getvar 'textsize))

(getvar 'DIMTXT)