home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p030 / 2.ddi / CL.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1988-08-04  |  3.8 KB  |  117 lines
  1. ; ******************************************************************
  2. ;                          CL.LSP
  3.  
  4. ;    By Simon Jones    Autodesk Ltd , London      March 1987
  5.  
  6. ;  This macro constructs a pair of center lines through the
  7. ;  center of a circle. The lines are put on a layer "CL".
  8.  
  9. ; ******************************************************************
  10.  
  11. (defun clerr (s)
  12.    (if (/= s "Function cancelled")   ; If an error (such as CTRL-C) occurs
  13.       (princ (strcat "\nError: " s)) ; while this command is active...
  14.    )
  15.    (command "UCS" "P")               ; Restore previous UCS
  16.    (setvar "BLIPMODE" sblip)         ; Restore saved modes
  17.    (setvar "GRIDMODE" sgrid)
  18.    (setvar "HIGHLIGHT" shl)
  19.    (setvar "UCSFOLLOW" sucsf)
  20.    (command "LAYER" "S" clay "")
  21.    (command "undo" "e")
  22.    (setvar "CMDECHO" scmde)
  23.    (setq *error* olderr)             ; Restore old *error* handler
  24.    (princ)
  25. )
  26.  
  27. (defun C:CL (/ olderr clay sblip scmde sgrid shl sucsf e cen rad d ts xx)
  28.    (setq olderr  *error*
  29.          *error* clerr)
  30.    (setq scmde (getvar "CMDECHO"))
  31.    (command "undo" "group")
  32.    (setq clay  (getvar "CLAYER"))
  33.    (setq sblip (getvar "BLIPMODE"))
  34.    (setq sgrid (getvar "GRIDMODE"))
  35.    (setq shl   (getvar "HIGHLIGHT"))
  36.    (setq sucsf (getvar "UCSFOLLOW"))
  37.    (setvar "CMDECHO" 0)
  38.    (setvar "GRIDMODE" 0)
  39.    (setvar "UCSFOLLOW" 0)
  40.    (setq e nil xx "Yes")
  41.    (setq ts (tblsearch "LAYER" "CL"))
  42.    (if (null ts)
  43.        (prompt "\nCreating new layer - CL. ")
  44.        (progn
  45.         (if (= (logand 1 (cdr (assoc 70 ts))) 1)
  46.             (progn
  47.              (prompt "\nLayer CL is frozen. ")
  48.              (initget  "Yes No")
  49.              (setq xx (getkword "\nProceed? <N>: "))
  50.              (if (= xx "Yes")
  51.                  (command "LAYER" "T" "CL" "")
  52.              )
  53.             )
  54.         )
  55.        )
  56.    )
  57.  
  58.    (if (= xx "Yes")
  59.       (progn
  60.        (while (null e)
  61.           (setq e (entsel "\nSelect arc or circle: "))
  62.           (if e
  63.               (progn
  64.                (setq e (car e))
  65.                (if (and
  66.                      (/= (cdr (assoc 0 (entget e))) "ARC")
  67.                      (/= (cdr (assoc 0 (entget e))) "CIRCLE")
  68.                    )
  69.                    (progn (prompt "\nEntity is a ")
  70.                           (princ (cdr (assoc 0 (entget e))))
  71.                           (setq e nil)
  72.                    )
  73.                )
  74.               )
  75.           )
  76.        )
  77.        (command "UCS" "e" e)
  78.        (setq cen (trans (cdr (assoc 10 (entget e))) e 1))
  79.        (setq rad (cdr (assoc 40 (entget e))))
  80.        (prompt "\nRadius is ")
  81.        (princ (rtos rad))
  82.        (initget 7 "Length")
  83.        (setq d (getdist "\nLength/<Extension>: "))
  84.        (if (= d "Length")
  85.         (progn
  86.          (initget 7)
  87.          (setq d (getdist cen "\nLength: "))
  88.         )
  89.         (setq d (+ rad d))
  90.        )
  91.        (setvar "BLIPMODE" 0)
  92.        (setvar "HIGHLIGHT" 0)
  93.        (command "LAYER" "M" "CL" "")
  94.        (command "LINE" (list (car cen) (- (cadr cen) d) (caddr cen))
  95.                        (list (car cen) (+ (cadr cen) d) (caddr cen))
  96.                        ""
  97.        )
  98.        (command "CHANGE" "l" "" "P" "LT" "CENTER" "")
  99.        (command "LINE" (list (- (car cen) d) (cadr cen) (caddr cen))
  100.                        (list (+ (car cen) d) (cadr cen) (caddr cen))
  101.                        ""
  102.        )
  103.        (command "CHANGE" "l" "" "P" "LT" "CENTER" "")
  104.        (command "LAYER" "S" clay "")
  105.       )
  106.    )
  107.    (command "UCS" "P")               ; Restore previous UCS
  108.    (setvar "BLIPMODE" sblip)         ; Restore saved modes
  109.    (setvar "GRIDMODE" sgrid)
  110.    (setvar "HIGHLIGHT" shl)
  111.    (setvar "UCSFOLLOW" sucsf)
  112.    (command "undo" "e")
  113.    (setvar "CMDECHO" scmde)
  114.    (setq *error* olderr)             ; Restore old *error* handler
  115.    (princ)
  116. )
  117.