[编程交流] 更改线路长度

(defun c:foo (/ l s)
 (if (and (setq l (getdist "\nEnter length: ")) (setq s (ssget ":L" '((0 . "*polyline,line")))))
   (foreach x (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
     (vl-cmdf "_Lengthen" "Total" l x "")
   )
 )
 (princ)
)

;| Change the Length of a Line|;
; BY: Tom Beauford
; BeaufordT@LeonCountyFL.gov
; Leon County Public Works Engineering
;(or C:chl (load "ChgLen.lsp"));chl
; (load "ChgLen.lsp") chl
;=======================================================
(defun C:chl (/ ActDoc A pick B etype pt1 pt pt2 pt3 pt4 distold dist1 ang1 z1)
 (setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
 (vla-StartUndoMark ActDoc)
 (setq A (entsel "\nSelect Entity: ")
    pick (osnap (cadr A) "endp")
       B (entget (car A))
   etype (cdr(assoc 0 B))
 ); setq
 (princ "\netype = ")
 (princ etype)
 (cond
   ((eq etype "LINE")
     (progn
       (setq pt1 (cdr (assoc 10 B)) pt2 (cdr (assoc 11 B)))
       (if (>(distance pt1 pick)(distance pick pt2))
        (setq pt pt1 pt1 pt2 pt2 pt)
       )
       (setq pt3 (list (car pt1)(cadr pt1)) pt4 (list (car pt2)(cadr pt2))
                 distold (distance pt3 pt4)
                 ang1 (angle pt2 pt1)
       )
       (princ "\nOld Distance=")
       (princ distold)
       (initget "Lengthen Shorten Total Elevation Percent Ratio")
       (if(= ¦¦global¦¦ nil)(setq ¦¦global¦¦ "Total"))
       (if(setq ¦¦notnil¦¦ (getkword (strcat " [Lengthen/Shorten/Total/Elevation/Percent/Ratio] <" ¦¦global¦¦ ">: ")))(setq ¦¦global¦¦ ¦¦notnil¦¦))
       (setvar "cmdecho" 0)
   (cond
     ((= ¦¦global¦¦ "Lengthen")
       (setq dist1 (+ distold (getreal "\nEnter Distance: "))
                 z1 (+(caddr pt2)(*(/ dist1 distold)(-(caddr pt1)(caddr pt2))))
       )
     ); Lengthen
     ((= ¦¦global¦¦ "Shorten")
       (setq dist1 (- distold (getreal "\nEnter Distance: "))
                 z1 (+(caddr pt2)(*(/ dist1 distold)(-(caddr pt1)(caddr pt2))))
       )
     ); Shorten
     ((= ¦¦global¦¦ "Total")
       (setq dist1 (getreal "\nEnter New Length: ")
                 z1 (+(caddr pt2)(*(/ dist1 distold)(-(caddr pt1)(caddr pt2))))
       )
     ); Total
     ((= ¦¦global¦¦ "Elevation")
       (setq z1 (getreal "\nEnter Elevation to Trim/Extend: ")
                 dist1 (*(/ distold (-(caddr pt1)(caddr pt2)))(- z1 (caddr pt2)))
         )
     ); Elevation
     ((= ¦¦global¦¦ "Percent")
       (setq z1 (+(caddr pt2)(* distold(getreal "\nEnter Slope in %: ")0.01))
                 dist1 distold
       )
     ); Percent
     ((= ¦¦global¦¦ "Ratio")
       (setq z1 (+(caddr pt2)(/ distold(getreal "\nEnter Run/Rise: ")))
                 dist1 distold
       )
     ); Ratio
   ); cond
       (setq pt1 (polar pt2 ang1 dist1)
                 pt1 (list (car pt1)(cadr pt1) z1)
       )
       (if pt (setq pt pt1 pt1 pt2 pt2 pt))
       (setq B (subst(cons 10 pt1)(assoc 10 B) B)
             B (subst(cons 11 pt2)(assoc 11 B) B)
       )
       (entmod B)
       (princ "\nOld Distance=")
       (princ distold)
       (princ ", New Distance=")
       (princ dist1)
     ); progn
   ); line
   ((or(eq etype "ARC")(eq etype "POLYLINE")(eq etype "LWPOLYLINE"))
     (progn
       (command "lengthen" pick)
     ); progn
   ); ARC, POLYLINE or LWPOLYLINE
 ); cond
 (vla-EndUndoMark ActDoc)
 (princ)
)