[编程交流] 拉伸多基点po

(defun c:Test1 (/ ent lst)
 (if
   (and (setq toLine (vlax-ename->vla-object (car (entsel "\nSelect Line: "))))
    (setq p1 (getpoint "\nSpecify First Point: "))
    (setq p2 (getpoint "\nSpecify Second Point: " p1))
    (setq ss (apply 'ssget
                          (append (list "_C")
                                  (mapcar '(lambda (foo) (apply 'mapcar (cons foo (list p1 p2))))
                                          '(min max)
                                  )
                                  (list '((0 . "*LINE")))
                          )
                   )
          )
    
          (setq lst0 ((lambda (l / i)
                       (setq i (lm:getobjintersectionsinss l ss))
                       (vla-delete l)
                       i
                     )
                      (vlax-ename->vla-object
                        (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2)))
                      )
                    )
          )
   )
    (progn
      (setq lst1 (mapcar 'cons (mapcar 'cadr (ssnamex ss)) lst0))
      (setq i 0)
      (repeat (sslength ss)
    (setq e (ssname ss i))
    (setq lst (cadr (at:segment int_f)))
    (setq Pintobj (LM:GetIntersections
            toLine
            (vlax-ename->vla-object e)
              )
    )
    (vl-cmdf "_.stretch"
         ss
         ""
         "_non"
         (trans lst 0 1)
         (trans (car Pintobj) 0 1)
    )
    (setq i (1+ i))
      )
    )
 )
 (princ)
)
(defun lm:getobjintersectionsinss (obj ss)
 ;; © Lee Mac 2010
 ((lambda (i / j a b ilst)
    (while (setq e (ssname ss (setq i (1+ i))))
      (setq ilst (append ilst
                         (lm:groupbynum (vlax-invoke obj
                                                     'intersectwith
                                                     (vlax-ename->vla-object e)
                                                     acextendnone
                                        )
                                        3
                         )
                 )
      )
    )
  )
   -1
 )
)
(defun AT:Segment (entPnt)
 ;; Retreive segment number and Start & End points
 ;; entPnt - List with entity (ENAME or VLA-OBJECT) & point
 ;; Alan J. Thompson, 11.10.09 / 08.19.10 / 11.15.11
 (if (vl-consp entPnt)
   ((lambda (e p / n)
      (if (setq n (vlax-curve-getPointAtParam e (1+ p)))
        (list p (list (vlax-curve-getPointAtParam e p) n))
        (list p (list (vlax-curve-getPointAtParam e (1- p)) (vlax-curve-getPointAtParam e p)))
      )
    )
     (car entPnt)
     (fix (vlax-curve-getParamAtPoint
            (car entPnt)
            (vlax-curve-getClosestPointToProjection
              (car entPnt)
              (trans (cadr entPnt) 1 (car entPnt))
              '(0. 0. 1.)
            )
          )
     )
   )
 )
)

(defun c:Test2 (/ toLine p1 p2 ss lst0 lst1 Pintobj vtx_pline list_vtx_pline)
 (if
   (and (setq toLine
       (vlax-ename->vla-object (car (entsel "\nSelect Line: ")))
    )
    (setq p1 (getpoint "\nSpecify First Point: "))
    (setq p2 (getpoint "\nSpecify Second Point: " p1))
    (setq ss
       (apply
         'ssget
         (append
           (list "_C")
           (mapcar
             '(lambda (foo) (apply 'mapcar (cons foo (list p1 p2))))
             '(min max)
           )
           (list '((0 . "*LINE")))
         )
       )
    )
    (setq
      lst0    ((lambda (l / i)
          (setq i (lm:getobjintersectionsinss l ss))
          (vla-delete l)
          i
        )
         (vlax-ename->vla-object
           (entmakex
             (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2))
           )
         )
       )
    )
   ) ;_and
    (progn
      ;; Find intersection between line and selection
      (setq Pintobj (lm:getobjintersectionsinss toLine ss))
      ;;(princ Pintobj) ;_for testing
      (setq cadrm (mapcar 'cadr (ssnamex ss)))
      ;; Make list (ename point_intersection)
      (setq lst1 (mapcar 'list cadrm lst0))
      (foreach    n lst1
    (setq p (fix
          (vlax-curve-getparamatpoint
            (car n)
            (vlax-curve-getclosestpointtoprojection
              (car n)
              (trans (cadr n) 1 0)
              '(0.0 0.0 1.0)
            )
          )
        )
    ) ;_setq p
    (setq vtx_pline
       (list
         (trans (vlax-curve-getpointatparam (car n) p) 0 1)
       )
    )
    ;;(princ vtx_pline) ;_for testing
    (setq list_vtx_pline (append list_vtx_pline vtx_pline)) ;_This is Start point of Selected Segment PLINES as base point of STRETCH:
      ) ;_foreach
      ;;(princ list_vtx_pline) ;_for testing
      (setq data (mapcar 'list cadrm list_vtx_pline pintobj))
      (foreach    m data
    (vl-cmdf "_.stretch"
         (car m)
         ""
         "_non"
         (cadr m)
         (caddr m)
    )
      )
    ) ;_progn
 ) ;_if
 (princ)
) ;_defun
(defun lm:getobjintersectionsinss (obj ss)
 ;; © Lee Mac 2010
 ((lambda (i / j a b ilst)
    (while (setq e (ssname ss (setq i (1+ i))))
      (setq ilst (append ilst
             (lm:groupbynum
               (vlax-invoke
                 obj
                 'intersectwith
                 (vlax-ename->vla-object e)
                 acextendnone
               )
               3
             )
         )
      )
    )
  )
   -1
 )
)
;;  Author: Lee Mac, Copyright © 2010 - www.lee-mac.com       ;;
(defun LM:GroupByNum (l n / r)
 (if l
   (cons
     (reverse (repeat n
        (setq r (cons (car l) r)
              l (cdr l)
        )
        r
          )
     )
     (LM:GroupByNum l n)
   )
 )
)

(setq pt1 (getpoint "Pick 1st crossing point"))
(setq pt2 (getpoint Pt1 "Pick 2nd crossing point"))
(setq vert (getint "Enter vertice position 2+ etc ")) ; do a left or right here pick end instead.
(setq ss (ssget "F" (list pt1 pt2))) ; selection set of plines
(command "Line" pt1 pt2 "") ; do after select or else line is added
(setq objL (vlax-Ename->Vla-Object (entlast))) ; saves line object for intersect erase at end.

; pline co-ords example
; By Alan H
(defun getcoords (ent)
 (vlax-safearray->list
   (vlax-variant-value
     (vlax-get-property
   (vlax-ename->vla-object ent)
   "Coordinates"
     )
   )
 )
)
; work in progress
(repeat (setq K (sslength ss)) ; loop through
(setq co-ords (getcoords (ssname ss (setq k (- k 1))))) ; pline co-ords ; uses getcoords defun
(setq objpl (vlax-Ename->Vla-Object (ssname ss k)))
(setq intpt1 (vlax-invoke objpl 'intersectWith objL acExtendThisEntity))
(setq x (car intpt1))
(setq y (cadr intpt1))
; do the ucs bit here erase line UCS OB then oops does it work 
(setq newlst '())
(setq len2 (length co-ords))
(repeat vert
(setq newlst (cons (list x (nth (setq len2 (- len2 1)) co-ords)) newlst))
) ; repeat vert
; add remaining pts 
(repeat (- len2 vert)
(setq newlst (cons (list x (nth (setq len2 (- len2 1)) co-ords)) newlst))
) ; repeat remainder
; erase pline and draw new pline
(setq J 0)
(command "pline" 
(repeat (length newlst)
(list (nth J newlst)(nth (+ J 1) newlst))
(setq J (+ J  2))
)
) ;repeat ss

(defun c:Test2 (/ pt1 pt2 vert ss objL K co-ords objpl intpt1 x y newlst len2)
 ;; http://www.cadtutor.net/forum/showthread.php?97882-Stretch-multiple-base-point-polylines-to-different-distance
 ;; BIGAL
 (setq pt1 (getpoint "Pick 1st crossing point"))
 (setq pt2 (getpoint Pt1 "Pick 2nd crossing point"))
 (setq vert (getint "Enter vertice position 2+ etc ")) ;_ do a left or right here pick end instead.
 (setq ss (ssget "F" (list pt1 pt2))) ;_ selection set of plines
 (command "Line" pt1 pt2 "") ;_ do after select or else line is added
 (setq objL (vlax-Ename->Vla-Object (entlast))) ;_ saves line object for intersect erase at end.
 ;; pline co-ords example
 ;; By Alan H
 (defun getcoords (ent)
   (vlax-safearray->list
     (vlax-variant-value
   (vlax-get-property
     (vlax-ename->vla-object ent)
     "Coordinates"
   ) ;_end of vlax-get-property
     ) ;_end of vlax-variant-value
   ) ;_end of vlax-safearray->list
 ) ;_end of defun
 ;; work in progress
 (repeat (setq K (sslength ss)) ;_ loop through
   (setq co-ords (getcoords (ssname ss (setq k (- k 1))))) ;_ pline co-ords ; uses getcoords defun
   (setq objpl (vlax-Ename->Vla-Object (ssname ss k)))
   (setq intpt1 (vlax-invoke objpl 'intersectWith objL acExtendThisEntity))
   (setq x (car intpt1))
   (setq y (cadr intpt1))
   ;; do the ucs bit here erase line UCS OB then oops does it work 
   (setq newlst '())
   (setq len2 (length co-ords))
   (repeat vert
     (setq newlst (cons (list x (nth (setq len2 (- len2 1)) co-ords))
            newlst
          ) ;_end of cons
     ) ;_end of setq
   ) ;_ repeat vert
   ;; add remaining pts 
   (repeat (- len2 vert)
     (setq newlst (cons (list x (nth (setq len2 (- len2 1)) co-ords))
            newlst
          ) ;_end of cons
     ) ;_end of setq
   ) ;_ repeat remainder
   ;; erase pline and draw new pline
   (setq J 0)
   (command "pline"
        (repeat (length newlst)
          (list (nth J newlst) (nth (+ J 1) newlst))
          (setq J (+ J 2))
        ) ;_end of repeat
   ) ;_end of command
 ) ;_repeat ss
 (princ)
) ;_defun