[编程交流] 测量多段之间的距离

;; written by Fatty T.O.H. ()2005 * all rights removed
;; edited 5/14/12
;; draw perpendicular lines
;;load ActiveX library
(vl-load-com)
;;local defuns
;;//
(defun start (curve)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getclosestpointto curve
 (vlax-curve-getstartpoint curve
   )
 )
)
   )
 )
 )
;;//
(defun end (curve)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getclosestpointto curve
 (vlax-curve-getendpoint curve
   )
 )
)
   )
 )
 )
;;//
(defun pointoncurve (curve pt)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getclosestpointto curve
 pt
   )
 )
)
   )
 )
;;//
(defun paramatpoint (curve pt)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getparamatpoint curve
 pt
   )
 )
)
   )
 )
;;//
(defun distatpt (curve pt)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getdistatpoint curve
   (vlax-curve-getclosestpointto curve pt)
   )
 )
   )
   )
 )
;;//
(defun pointatdist (curve dist)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getclosestpointto curve
 (vlax-curve-getpointatdist curve dist)
   )
 )
)
   )
 )
;;//
(defun curvelength (curve)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getdistatparam curve
 (- (vlax-curve-getendparam curve)
    (vlax-curve-getstartparam curve)
   )
 )
 )
)
   )
 )
;;//
(defun distatparam (curve param)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getdistatparam curve
 param
 )
 )
   )
   )
 )
;;// written by VovKa (Vladimir Kleshev)
(defun gettangent (curve pt)
 (setq param (paramatpoint curve pt)
       ang ((lambda (deriv)
    (if (zerop (cadr deriv))
      (/ pi 2)
      (atan (apply '/ deriv))
    )
  )
   (cdr (reverse
   (vlax-curve-getfirstderiv curve param)
        )
   )
 )
)
 ang
 )
;;// main program
;;--------------------------------------------------;;
(defun c:DIP (/ *error* acsp adoc cnt div en en2 ent ent2 ip lastp leng ln lnum mul num pt rot sign start step)
 (defun *error* (msg)
     (vla-endundomark (vla-get-activedocument
             (vlax-get-acad-object))
      )
   (cond ((or (not msg)
       (member msg '("console break" "Function cancelled" "quit / exit abort"))
       )
   )
  ((princ (strcat "\nError: " msg)))
  )
   (princ)
   )
 (setq adoc (vla-get-activedocument (vlax-get-acad-object))
   acsp (vla-get-block (vla-get-activelayout adoc))
    )
(while (not
  (and
    (or
      (initget 6)
      (setq step (getreal "\nEnter step <50>: "))
      (if (not step)
 (setq step 50.)))
    ))
  (alert "\nEnter a step")
  )
(if (and
 (setq
   ent (entsel
  "\nSelect polyline 1 >>"
  )
   )
(setq
   ent2 (entsel
  "\nSelect polyline 2  >>"
  )
   )
 )
  (progn
    (setq en (car ent)
   pt (pointoncurve en (cadr ent))
   leng (distatparam en (vlax-curve-getendparam en))
   en2 (car ent2)
   )
    (setq num (fix (/ leng step))
   )
    (setq div (fix (/ 100. step)
     )
   )
    (setq mul (- leng
   (* (setq lnum (fix (/ leng (* step div)))) (* step div))))
    (if (not (zerop mul))
      (setq lastp T)
      (setq lastp nil)
      )
    (if (> (- (paramatpoint en pt)
       (paramatpoint en (vlax-curve-getstartpoint en))
       )
    (- (paramatpoint en (vlax-curve-getendpoint en))
       (paramatpoint en pt)
       )
    )
      (progn
 (setq start leng
       sign  -1
       )
 )
      (progn
 (setq start (distatparam en (vlax-curve-getstartparam en))
       sign  1
       )
 )
      )
    (vla-startundomark
      (vla-get-activedocument (vlax-get-acad-object))
      )
    (setq cnt 0)
    (repeat (1+ num)
      (setq pt  (pointatdist en start)
     rot (gettangent en pt)
     )
(setq ln (vlax-invoke-method acsp 'addline (setq ip (vlax-3d-point pt))(vlax-3d-point(pointoncurve en2 pt))))
      (setq cnt   (1+ cnt)
     start (+ start (* sign step))
     )
      )
    (if lastp
      (progn
 (if (= sign -1)
   (progn
     (setq pt  (vlax-curve-getstartpoint en)
    rot (gettangent en pt)
    )
     )
   (progn
     (setq pt  (vlax-curve-getendpoint en)
    rot (gettangent en pt)
    )
     )
   )
(setq ln (vlax-invoke-method acsp 'addline (setq ip (vlax-3d-point pt))(vlax-3d-point(pointoncurve en2 pt))))
 )
      )
    )
  (princ "\nNothing selected")
  )
 (*error* nil)
(princ)
)
(prompt "\n   >>>   Type DIP to execute...")
(prin1)

                               
登录/注册后可看大图