[编程交流] 圆角替换所有半径

(defun c:filletreplace (/ *error* ent ent8)
 (defun *error* (msg)
   (if (not
         (member msg '("Function cancelled" "quit / exit abort"))
       )
     (princ (strcat "\nError: " msg))
   )
   (princ)
 )
 (setq prd (lambda (x) (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x)))))))
 (if (and
       (setq ent
              (car (LM:SelectIf "\nSelect polyline on layer you want to replace radii: " prd entsel nil)
              )
       )
       (filletreplace:settings)
     )
   (progn
     (setq ent8 (cdr (assoc 8 (entget ent)))
           cnt  0
     )
     (setq ss (ssget "_A"
                     (list '(0 . "LWPOLYLINE")
                           (cons 8 ent8)
                     )
              )
     )
     (repeat (sslength ss)
;;;I am getting stuck here on iterating over the polyline and checking the radius
         (setq cnt (+ cnt 1))
       )
     )
   )
 )
 (princ)
)
;;;
(defun filletreplace:settings ()
 (setq *filletorigans*
        (cond
          (
           (getreal
             (strcat "\nOriginal radii <"
                     (rtos *filletorigans* 2 2)
                     ">: "
             )
           )
          )
          (*filletorigans*)
        )
 )
 (setq *filletreplans*
        (cond
          (
           (getreal
             (strcat "\nReplacement radii <"
                     (rtos *filletreplans* 2 2)
                     ">: "
             )
           )
          )
          (*filletreplans*)
        )
 )
)
;;;
;;---------------------=={ Select if }==----------------------;;
;;                                                            ;;
;;  Provides continuous selection prompts until either a      ;;
;;  predicate function is validated or a keyword is supplied. ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - [url="http://www.lee-mac.com"]www.lee-mac.com[/url]       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  msg  - prompt string                                      ;;
;;  pred - optional predicate function [selection list arg]   ;;
;;  func - selection function to invoke                       ;;
;;  keyw - optional initget argument list                     ;;
;;------------------------------------------------------------;;
;;  Returns:  Entity selection list, keyword, or nil          ;;
;;------------------------------------------------------------;;
(defun LM:SelectIf (msg pred func keyw / sel)
 (setq pred (eval pred))
 (while
   (progn (setvar 'ERRNO 0)
          (if keyw
            (apply 'initget keyw)
          )
          (setq sel (func msg))
          (cond
            ((= 7 (getvar 'ERRNO))
             (princ "\nMissed, Try again.")
            )
            ((eq 'STR (type sel))
             nil
            )
            ((vl-consp sel)
             (if (and pred (not (pred sel)))
               (princ "\nInvalid Object Selected.")
             )
            )
          )
   )
 )
 sel
)

(defun c:DyF (/ *error* _pnt AT:GetSel vl ov ent plst elst gr sp)
 ;; Dynamic Fillet
 ;; Alan J. Thompson, 03.07.11 / 03.09.11
 (vl-load-com)
 (defun *error* (msg)
   (redraw)
   (and vl (mapcar (function setvar) vl ov))
   (and elst (mapcar (function redraw) elst '(4 4)))
   (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
     (princ (strcat "\nError: " msg))
   )
 )
 (defun _pnt (p) (trans (list (car p) (cadr p)) 0 1))
 (defun AT:GetSel (meth msg fnc / ent)
   ;; meth - selection method (entsel, nentsel, nentselp)
   ;; msg - message to display (nil for default)
   ;; fnc - optional function to apply to selected object
   ;; Ex: (AT:GetSel entsel "\nSelect arc: " (lambda (x) (eq (cdr (assoc 0 (entget (car x)))) "ARC")))
   ;; Alan J. Thompson, 05.25.10
   (setvar 'ERRNO 0)
   (while
     (progn (setq ent (meth (cond (msg)
                                  ("\nSelect object: ")
                            )
                      )
            )
            (cond ((eq (getvar 'ERRNO) 7) (princ "\nMissed, try again."))
                  ((eq (type (car ent)) 'ENAME)
                   (if (and fnc (not (fnc ent)))
                     (princ "\nInvalid object!")
                   )
                  )
            )
     )
   )
   ent
 )
 (if (setq ent
            (car
              (AT:GetSel
                entsel
                "\nSelect arc: "
                (lambda (x)
                  (if (eq "ARC" (cdr (assoc 0 (entget (car x)))))
                    (vl-every (function (lambda (p / ss)
                                          (if (setq ss (ssget "_C" p p '((0 . "LINE"))))
                                            (setq elst (cons (ssname ss 0) elst))
                                          )
                                        )
                              )
                              (setq plst (list (_pnt (vlax-curve-getStartPoint (car x)))
                                               (_pnt (vlax-curve-getEndPoint (car x)))
                                         )
                              )
                    )
                  )
                )
              )
            )
     )
   (progn
     (setq ov (mapcar (function getvar) (setq vl '("CMDECHO" "FILLETRAD"))))
     (while
       (progn
         (setq gr (grread T 15 0))
         (cond
           ((eq 5 (car gr))
            (redraw)
            (grdraw (setq sp (trans (vlax-curve-getStartPoint ent) 0 1)) (cadr gr) 1 -1)
            (princ
              (strcat "\rFillet radius: "
                      (rtos (setvar 'FILLETRAD (distance sp (cadr gr))))
                      "      "
              )
            )
            (if (vl-cmdf "_.fillet" (list (car elst) (car plst)) (list (cadr elst) (cadr plst)))
              (progn (entdel ent) (setq ent (entlast)))
              T
            )
           )
         )
       )
     )
   )
 )
 (*error* nil)
 (princ)
)