[LISP程序]：网上找的局部放大程序

jx2008

以下是在明经里找的局部放大程序，测试之后发现没有把要放大的区域copy出来放在要放大之后的圆圈里，这是怎么回事？请高手修改一下，谢谢！

(prompt "\\nDETAIL - (c)1998 AUTO-CODE MECHANICAL - *FREEWARE*")
;;
;; FREEWARE Program - you are free to make copies of this and supply it
;;                    to others as is.  Author and company make no
;;                    warrenty on the fitness of this program for anything
;;                    other than using as an example when learning
;;                    AutoLISP.
;;
;; Adapted from the CADENCE January 1999 article by Bill Kramer
;;
;; Detail enlargement macro set.
;;-----------------------------------------------
;; The Main Program
;;-----------------------------------------------
(defun C:DETAIL ( / P1 EN EL PTS SS1)
  (cond
   ;;Set up AutoCAD system variables
   ((DETAIL_0)
      (prompt "\\nError in DETAIL_0"))
   ;;
   ;;Operator input of detail center
   ;;and radius.
   ((DETAIL_1) ;;set up EL, P1, RD
      (prompt "\\nError in DETAIL_1"))
   ;;
   ;;Operator input of detail graphic location
   ;;and scale for detail display.
   ;;Copy detail area, remove non-detail objects
   ;;like dimensions and text, and scale as
   ;;input by the operator.
   ((DETAIL_2) ;;set up P2, SS1, EN, ENT, SCL
      (prompt "\\nError in DETAIL_2"))
   ;;
   ;;Do the trimming of the detail display.
   ((DETAIL_3)
      (prompt "\\nError in DETAIL_3"))
   ;;
   ;;Create the text tag and draw connecting
   ;;line between original area and detail
   ;;area.
   ((DETAIL_4) ;;Output text tag
      (prompt "\\nError in DETAIL_4"))
   ('T (prompt "\\nDetail finished okay."))
  )
  ;;
  ;;Reset system variables
  (mapcar '(lambda (X)
      (setvar (car X) (cadr X))) SYSVAR_LIST)
  (prompt "\\nUse TRIM to complete if needed.")
  (princ)
)
;;-----------------------------------------------
;; Listing 2: Set up system variables
;;-----------------------------------------------
(defun DETAIL_0 ()
   (setq SYSVAR_LIST (mapcar '(lambda (X)
     (list X (getvar X)))
     '("CMDECHO"
       "OSMODE"
       "ORTHOMODE"
       "HIGHLIGHT"
      )))
   (setvar "CMDECHO" 0)
   (setvar "OSMODE" 0)
   (setvar "ORTHOMODE" 0)
   (setvar "HIGHLIGHT" 0)
   (if (zerop (getvar "TILEMODE")) ;;make sure we are mspace
      (if (= (getvar "CVPORT") 1) (progn ;;we are in paper space!
         (alert "You must be in Model Space for this routine to function!")
         (exit) ;;hard abort!
      ))
   )
   (if (zerop (getvar "WORLDUCS"))
     (command "_UCS" "_W"))
   nil
)
;;-----------------------------------------------
;; Listing 3: Establish area to detail
;;-----------------------------------------------
(defun DETAIL_1 ()
   (setq P1 (getpoint "\\nDetail center: "))
   (if P1 (progn
      (prompt "\\nShow detail area: ")
      (command "_CIRCLE" P1 pause)
      (setq EN (entlast)
            EL (entget EN)
            RD (if (= (cdr (assoc 0 EL)) "CIRCLE")
                  (cdr (assoc 40 (entget EN)))
                  nil)
      )
      (if RD (progn
         (entdel EN)
         (command "_POLYGON" 15 P1 "I" RD)
         (setq EN (entlast)
               EL (entget EN)
         )
         nil  ;return nil
       )
       1 ;return error level 1.
      ) ;;level 1 is RD not set
    )
    2 ;;return error level 2.
   ) ;level 2 is P1 not set
)
;;-----------------------------------------------
;; Listing 4: Copy objects to new location
;;-----------------------------------------------
(defun DETAIL_2 ()
   (while (setq TMP (assoc 10 EL))
      (setq EL (cdr (member TMP EL))
            PTS (cons (cdr TMP) PTS)
      )
   )
   (entdel EN)
   (setq SS1 (ssget "CP" PTS)
         P2 (getpoint P1 "\\nPut detail at: ")
         CNT (if SS1 (sslength SS1) 0)
   )
   (if P2 (progn
     (repeat CNT
        (if (member
           (cdr (assoc 0
             (entget
                (ssname
                   SS1
                   (setq CNT (1- CNT))))))
           '("TEXT" "DIMENSION"
             "MTEXT" "INSERT"
            )
          )
         (ssdel (ssname SS1 CNT) SS1)
        )
     )
     (command "_CIRCLE" P1 RD
              "_CIRCLE" P2 RD)
     (setq EN (entlast)
           ENT EN)
     (command "_COPY" SS1 "" P1 P2)
     (setq SS1 (ssadd EN))
     (while (setq ENT (entnext ENT))
        (ssadd ENT SS1)
     )
     (setq SCL (getreal "\\nScale factor (2): "))
     (if (null SCL) (setq SCL 2.0))
     (if (/= SCL 1.0)
        (command "_SCALE" SS1 "" P2 SCL)
     )
     nil ;;return nil result, all okay.
    )
    1 ;;return error code 1
   ) ;;error code, P2 not input.
)
;;-----------------------------------------------
;; Listing 5: Trim the objects copied
;;-----------------------------------------------
(defun DETAIL_3 ()
   (setq TTT 0) ;;change counter
   (while (setq ENT (ssname SS1 0))
     (ssdel ENT SS1)
     (if (not (equal ENT EN)) (progn
        (setq EL (entget ENT)
              PT (DETAIL_3A EL)
        )
        (if (and PT
              (> (distance P2 PT)
                 (+ 0.2 (* RD SCL))))
         (progn
          (setq TTT (1+ TTT))
          (command "_TRIM" EN ""
                   (list ENT PT) "")
        ))
     ))
     (DETAIL_3B) ;;loop again check
   )
   nil
)
;;-----------------------------------------------
;; Listing 6: Find point on object for trim
;;-----------------------------------------------
(defun DETAIL_3A (EL / TY)
   (setq TY (cdr (assoc 0 EL)))
   (cond
     ((= TY "LINE")
       (if (> (distance (cdr (assoc 10 EL)) P2)
           (distance (cdr (assoc 11 EL)) P2))
         (cdr (assoc 10 EL))
         (cdr (assoc 11 EL))
       )
     )
     ((= TY "ARC")
       (setq PC (cdr (assoc 10 EL))
             PR (cdr (assoc 40 EL))
             PA (cdr (assoc 50 EL))
             PB (cdr (assoc 51 EL))
       )
       (if (> (distance (polar PC PA PR) P2)
              (distance (polar PC PB PR) P2))
          (polar PC PA PR)
          (polar PC PB PR)
       )
     )
     ((= TY "CIRCLE")
       (setq PC (cdr (assoc 10 EL))
             PR (cdr (assoc 40 EL))
       )
       (cond
         ((> (distance P2
                      (polar PC 0.0 PR))
             (* RD SCL))
            (polar PC 0.0 PR))
         ((> (distance P2
                      (polar PC PI PR))
             (* RD SCL))
            (polar PC PI PR))
         ((> (distance P2
                      (polar PC (* 0.5 PI) PR))
             (* RD SCL))
            (polar PC (* 0.5 PI) PR))
         (t (polar PC (* 1.5 PI) PR))
       )
     )
     ((= TY "LWPOLYLINE")
       (setq PR nil)
       (while (and (null PR)
                   (setq PA (assoc 10 EL)))
          (setq EL (cdr (member PA EL))
                PA (cdr PA)
          )
          (if (> (distance P2 PA) (* RD SCL))
             (setq PR PA)))
     )
     ((= TY "SPLINE")
       (setq PR nil)
       (while (and (null PR)
          (setq PA (assoc 11 EL))
                EL (cdr (member PA EL))
                PA (cdr PA))
          (if (> (distance P2 PA) (* RD SCL))
             (setq PR PA)))
     )
     ((= TY "POLYLINE")
       (setq EL (entget
                  (entnext
                     (cdr (assoc -1 EL))))
             PR nil)
       (while (and (null PR)
                   (= (cdr (assoc 0 EL))
                      "VERTEX"))
          (setq PA (cdr (assoc 10 EL))
                EL (entget
                     (entnext
                        (cdr (assoc -1 EL))))
          )
          (if (> (distance P2 PA)
                 (* RD SCL))
             (setq PR PA)
          )
       )
     )
     ;;add more objects here
   ) ;;end COND for PT assignment
)
;;-----------------------------------------------
;; Listing 7: Loop control options for user
;;-----------------------------------------------
(defun DETAIL_3B ()
   (if (= (sslength SS1) 0)
      (if (> TTT 0) (progn
         (initget 0 "Yes No")
         (setq TTT (getkword (strcat
              "\\nChanged "
              (itoa TTT)
              " objects, Loop again? <Yes>")))
         (if (or (null TTT) (= TTT "Yes"))
            (progn
              (setq SS1 (ssadd EN)
                    ENT EN)
              (while (setq ENT (entnext ENT))
                (ssadd ENT SS1)
              )
              (setq TTT 0)
         ))
      ))
   )
)
;;-----------------------------------------------
;; Listing 8: Finishing touches
;;-----------------------------------------------
(defun DETAIL_4 ()
   (command "_TEXT"
            "_Justify" "_Center"
             (polar P2
                   (* PI 1.5)
                   (+ (* SCL RD)
                      (* 2.5
                         (getvar "TEXTSIZE"))))
   )
   (if (zerop (cdr (assoc 40
              (tblsearch
                 "STYLE"
                 (getvar "TEXTSTYLE")))))
      (command "") ;;text height output option
   )
   (command 0 ;;finish the TEXT command sequence.
            (strcat "Enlarged "
                    (rtos SCL 2
                      (Best_Prec SCL 0 4))
                    "x")
   )
   ;;
   ;; Construct line between detail circles.
   ;;
   (command "_LINE" (polar P1 (angle P1 P2) RD)
            (polar P2 (angle P2 P1) (* RD SCL))
            "")
   nil
)
;;-----------------------------------------------
;; Listing 9: Utility Routine from toolbox
;;-----------------------------------------------
;; Best_Prec - Given a number (NUM) and the
;; minimum and maximum precision, this Function
;; returns the precision in the range that will
;; best fit the number.
;;
(defun Best_Prec (Num Mn Mx)
   (while (and (<= Mn Mx)
               (/= Num (atof (rtos Num 2 Mn))))
      (setq Mn (1+ Mn))
   )
   Mn
)

qixiaochuan

很好用，没有楼上说的问题！估计你英语太差，基本命令提示都看不明白！

Michael_66

我英语也不好，不过我想测试一下

hstea

要是哪位高手可以把圆圈改为方框就好了！

我欲成魔

编程我不会，来试一下！

yzys

试一下看看

ooohen

谢谢!!试试看看!!

我们——

试一下看看

blc007

可以用，在试试吧，

yinzhun22

试一下看看

zhaozwf

放大后的下面说明不能随着一起放大，不是太爽，有高手可以改一下

znchssy

看看好用吗