[编程交流] 第二条路线的链测长度

;; @file: measure a curved line; every 500 units draw a perpendicular line.  We are looking for the intersection of the perpendicular lines with a second curved line
;; @author: Emmanuel Delay - emmanueldelay@gmail.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; resources ...
(vl-load-com)
(setq modelSpace (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-Acad-Object))))
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; main function
(defun perp (dist / curve-obj curve-second points xlines intersections)
 (setq 
   curve-obj (entsel "\n Select a curve:")                             ;; client selects the curved object, to be measured
   curve-second (entsel "\n Select a second curve:")                   ;; client selects the second object;
   points (getMeasurePoints dist curve-obj)                            ;; list of all the points.  From those points we draw the perpendicular lines
   xlines (drawPerpendicularLines points curve-obj curve-second)       ;; Construction lines (xline) 
   intersections (getIntersections xlines curve-second)                ;; returns a list of intersection points
 )
 (princ "\nIntersection points:\n")
 (princ intersections)
)
;; measures a polyline, returns a list of points, all "dist" away from each other, along the curve
(defun getMeasurePoints (dist curve / points needle pt)
 (setq 
   needle dist
   points (list)
   pt nil
 )
 (while (and                                                           ;; repeat while vlax-curve-getPointAtDist keeps finding a new point
     (setq pt (vlax-curve-getPointAtDist (car curve) needle))
     (/= nil pt)
   )
     (setq 
       points (append points (list pt))
     )
     (setq needle (+ needle dist))
 )
 points
)
(defun drawPerpendicularLines (points curve curve-second / i pt p xlines vl-obj x)
 (setq 
   i 0
   xlines (list)
 )
 (repeat (length points)
   (setq pt (nth i points))
   (setq vl-obj (vlax-ename->vla-object (car curve)))
   (setq x 
     (vlax-curve-getParamAtPoint vl-obj
       (setq 
         p (vlax-curve-getClosestPointTo vl-obj pt)
        )
     )
   )
   (setq xlines (append 
     xlines
     (list (drawPerpendicularLine curve curve-second x pt))
   ))
   (setq i (+ i 1))
 )
 xlines
)
(defun drawPerpendicularLine (curve curve-second param pt / deriv PTDERIV ptg xline)
 ;; @see http://cadxp.com/topic/21475-vlax-curve-getfirstderiv/
 (setq deriv (vlax-curve-getFirstDeriv (vlax-ename->vla-object (car curve)) param))
 (setq PTDERIV (mapcar '+ pt deriv))
 ;; get a point, distance 10000.0, angle: perpendicular
 (setq ptg (polar pt (+ (angle pt PTDERIV) (/ pi 2)) 10000.00))
 (setq xline (drawXline ptg pt))
 xline
)
(defun getIntersections (xlines curve-second / i intersects)
 (setq 
   i 0
   intersects (list)
 )
 (repeat (length xlines)
   (setq intersects (append intersects (list
     (vlax-invoke 
       (nth i xlines)
       'IntersectWith 
       (vlax-ename->vla-object (car curve-second)) 
     3)
   )))
   (setq i (+ i 1))
 )
 intersects
)
(defun drawXline (p1 p2)
 (vla-AddXline modelSpace (vlax-3d-point p1) (vlax-3d-point p2))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; command PERP
(defun c:perp ( / )
 (perp 500)
 (princ)
)

(defun c:pso ( / cl1 cl2  d  pt pt2 templine ang spc )
;;;                pBe 30Aug2014                ;;;
         (if (and
      (princ "\nSelect the main alignment")
      (setq cl1 (ssget "_:S" '((0 . "*POLYLINE"))))
      (princ "\nSelect the offset alignment")
      (setq cl2 (ssget "_:S" '((0 . "*POLYLINE"))))
      )
(progn
 [color="blue"] (setq d (cond ((getdist
       (strcat "\nEnter increment value: " " <" (rtos (setq d
             (cond ( d_ ) ( 100.00 ))
           ) 2 2) ">: ")))
   ( d )
 )
     )[/color]
  (setq cl1 (ssname cl1 0)
        cl2 (ssname cl2 0) d_ d)
  (while (setq pt (vlax-curve-getpointatdist cl1 d))
            (setq ang (angle '(0.0 0.0 0.0)
                         (vlax-curve-getfirstderiv
                           cl1
                           (vlax-curve-getparamatpoint cl1 pt)
                         )
                  )
        )
            (setq templine        (vlax-invoke (setq spc (vlax-get
                           (vla-get-ActiveLayout
                      (vla-get-ActiveDocument (vlax-get-acad-object )))
                                             'Block)) '[color="blue"]AddXline[/color] pt
          (polar pt (setq ang (+ ang  (* pi 1.5))) 1))
        )
        (if (setq pt2 (vlax-invoke
                        templine
                        'IntersectWith
                        (vlax-ename->vla-object cl2)
                        0
                      )
            )
           [color="red"] (vlax-invoke  spc 'Addline pt (list (Car pt2)(cadr pt2)(caddr pt2)))[/color]
        )
    (vla-delete templine)
    (setq d (+ d d_))
    )
  )
  )
  (princ)
  )
(vl-load-com)