[分享]：改变圆/弧的直径

sdwy19691229

改变圆/弧的直径
(defun c:CHD ( ) (setvar "cmdecho" 0)  
             (command "UNDO" "G")
             (setvar "osmode" 0)
             (setq e1 (entsel "\n选择一个圆/弧:"))
             (if (= e1 nil) (princ)  (progn
             (setq en (cdr (assoc '0  (entget (car e1)) )))
             (if (and (/= en "ARC")(/= en "CIRCLE"))(princ)
             (progn
             (setq ena (cdr (assoc '-1  (entget (car e1)) )))
             (redraw ena 3)
             (setq R (cdr (assoc '40  (entget (car e1)) )))
             (setq D1 (* R 2))
             (princ "\n将当前圆/弧的直径由<")(princ D1)(princ ">改为<")
             (princ D1)(PRINC ">:")
             (setq D2 (getreaL ))
             (redraw ena 4)
             (if (= D2 nil)(princ)
             (progn
             (setq R2 (/ D2 2))
             (setq ent (entget (car e1)))
             (setq ent (subst (cons '40 R2) (assoc '40 ent) ent))
             (entmod ent)                        
             (setvar "osmode" 53)
             (princ "\n你已经将圆/弧的直径作了修改  OK!")
             ))  ))  ))
             (command "UNDO" "E")
             (princ)   )

xyp1964

;;;改多圆、圆弧半径
[php](defun c:test008 (/ ll ll0 si cc ty r0)
  (cmdla0)
  (setq no1 (udist 1 "" "\n\t新半径" no1 (list 0 0)))
  (vl-cmdf ".undo" "BE")
  (while (setq ss (ssget))
    (setq ll  (sslength ss)
          ll0 -1
    )
    (repeat ll
      (setq ll0        (+ ll0 1)
            si        (ssname ss ll0)
            cc        (entget si)
            ty        (cdr (assoc 0 cc))
      )
      (if (or (= ty "CIRCLE") (= ty "ARC"))
        (progn
          (setq        r0 (cdr (assoc 40 cc))
                cc (subst (cons 40 no1) (assoc 40 cc) cc)
          )
          (entmod cc)
          (entupd si)
        )
      )
    )
  )
  (vl-cmdf ".undo" "E")
  (cmdla1)
)
(defun CMDLA0 ()
  (setq cmdech (getvar "CMDECHO"))
  (setq oom (getvar "orthomode"))
  (setq osm (getvar "osmode"))
  (SETQ LA (getvar "clayer"))
  (setq rmode (getvar "regenmode"))
  (setq pw (getvar "plinewid"))
  (setvar "regenmode" 0)
  (setvar "CMDECHO" 0)
  (princ)
)
(defun CMDLA1 ()
  (setvar "CMDECHO" cmdech)
  (setvar "orthomode" oom)
  (setvar "osmode" osm)
  (setvar "clayer" LA)
  (setvar "regenmode" rmode)
  (setvar "plinewid" pw)
  (princ)
)
(defun udist (bit kwd msg def bpt / inp)
  (if def
    (setq msg (strcat "\n" msg "<" (rtos def) ">:")
          bit (* 2 (fix (/ bit 2)))
    )
    (setq msg (strcat "\n" msg ":"))
  )
  (initget bit kwd)
  (setq inp
    (if bpt
      (getdist msg bpt)
      (getdist msg)
    ))
  (if inp inp def)
)
[/php]

sdwy19691229

下面是3个不同的 大量修改圆的程序

大量修改同径圆
(defun c:Chcc (/ R1 SST x y )
                (setvar "cmdecho" 0)
                (setq R1 (GETdist "\n输入修改后的圆半径:"))
                (setq sst (SSGET '((0 . "CIRCLE")) ))
                (setq n (sslength sst))
                (setq m (- n 1))
                (setq x 0)
                (setq Y (ssname sst x))
                (command "change" y """" R1 )
                (while (< x m)
                            (setq x (+ x 1))
                            (setq Y (ssname sst x))
                            (command "change" y """" R1 )
                 )
                (princ)
          )

-----------------------------------------------------------------------------------------------------------
修改圆直径功能?
------------------------MAIN PROGRAME-----------------------------------------------
(DEFUN C:BBCC()
           (SETQ OLDERR *ERROR*
                *ERROR* KK-ERR)
                 (setvar "cmdecho" 0)
                 (command "undo" "m")
                 (SETQ SS  (SSGET)
                       LEN (SSLENGTH SS)
                       SSA (SSADD)
                       SEA (SSADD)
                       LA  LEN
                 );SETQ
               (INITGET "Object Diameter Radius")
               (SETQ CO (GETREAL "\nTHE OLD Diameter/Radius/Object(X.XXX)/<D>:"))
               (COND
                     ((= CO "Radius")
                      (SETQ CO (* 2 (GETREAL "Radius(X.XXX):")))
                     )
                     ((OR (= CO "Diameter") (= CO ""))
                      (SETQ CO (GETREAL "Diameter(X.XXX):"))
                     )
                     ((= CO "Object")
                       (PROGN
                               (SETQ N NIL)
                                  (WHILE (NOT N)
                                     (SETQ N (CAR (ENTSEL "\nPick a CIRCLE!")))
                                  );WHILE

                          (SETQ EN (ENTGET N)
                                MC (CDR (ASSOC 0 EN))
                          );SETQ
                                  (WHILE (/= MC "CIRCLE")
                                     (SETQ N NIL)
                                        (WHILE (NOT N)
                                            (SETQ N (CAR (ENTSEL "\nPick a CIRCLE!")))
                                        );WHILE
                                     (SETQ  EN (ENTGET N)
                                            MC (CDR (ASSOC 0 EN))
                                     )
                                  );WHILE
                          (SETQ CO (* 2 (CDR (ASSOC 40 EN))))
                        );PROGN
                     )
                        (T NILE)
                );COND
                     
                (SETQ RO (/ CO 2.0))
               
                          (WHILE (> LA 0)
                               (SETQ NAMEA (SSNAME SS (- LA 1))
                                    ENTA  (ENTGET NAMEA)
                                    MARKA (= (CDR (ASSOC 0 ENTA)) "CIRCLE")
                               )
                             (IF  MARKA
                                   (SSADD NAMEA SSA)
                                    
                             );IF
                               (SETQ LA (- LA 1))
                          );WHILE
                          (SETQ LENA (SSLENGTH SSA))
                   (WHILE (> LENA 0)
                         (SETQ NAA  (SSNAME SSA (- LENA 1))
                               ENA  (ENTGET NAA)
                               RID  (ASSOC 40 ENA)
                               DIA  (* (CDR RID) 2.0)
                               LENAB (- LENA 1)
                         )
                           (IF  (EQUAL DIA CO 0.001)
                                   (SSADD NAA SEA)
                           );IF
                           (SETQ LENA (- LENA 1))
                   );WHILE

                  (SETQ L3 (SSLENGTH SEA))
                  (PRINC "\nFOUND ")
                  (PRINC L3)
                  (PRINC " CIRCLE(S)!")
                (IF (/= L3 0)
                    (PROGN
                           (INITGET "Radius Diameter")
                           (SETQ  CN (GETREAL "\nTHE NEW Diameter/Radius<D>:") )
                       (COND
                             ((= CN "Radius")
                             (SETQ CN (* 2 (GETREAL "Radius(X.XXX):")))
                             )   
                             ((OR (= CN "Diameter")(= CN ""))
                             (SETQ CN (GETREAL "Diameter(X.XXX):"))
                             )
                         (T NILE)
                       );COND
                    );PROGN
                );IF
                   (SETQ RN (/ CN 2.0))
                     (WHILE (> L3 0)
                            (SETQ NA3  (SSNAME SEA (- L3 1))
                                  ENA3  (ENTGET NA3)
                                  RID3  (CDR (ASSOC 40 ENA3))
                                  DIA3  (* RID3 2.0)
                            )
                         (SETQ ENA3 (SUBST (CONS 40 RN) (ASSOC 40 ENA3) ENA3))
                         (ENTMOD ENA3)
                         (SETQ L3 (- L3 1))
                     );WHILE
                  (SETQ *ERROR* OLDERR)
           (PRINC)
        )
-------------------------------*** END ***------------------------------------------
大量修改同径圆

(defun c:CHC () (setvar "cmdecho" 0)
               (setq R1 (GETdist "\n输入修改后的圆半径:"))
               (setq B (entsel "\n选择一个圆进行修改:"))
               (command "change" B "" "" R1)
               (while B
               (command "change" B "" "" R1)
               (setq B (entsel "\n选择一个圆进行修改:")) (princ)
))