home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p047 / 4.ddi / TY / WSCALE.LSP < prev    next >
Encoding:
Text File  |  1990-04-13  |  2.3 KB  |  69 lines
  1. ;****** TY\WSCALE.LSP ******  4-12-90 BJ
  2. (if (null tb) (setq tb 0.0))
  3. ;----------
  4. (defun C:WSCALE ( )
  5.   (setq ppp (ssget))
  6. ; (command "style" "" "" 2.0 "" "" "")
  7. ; (command "dim1" "new" ppp)
  8.   (setq pbase (getpoint "\n Base point:"))
  9.   (command "scale" ppp "" pbase 2)
  10.   (setq wcy 0 n (sslength ppp))
  11.     (while (< wcy n)
  12.       (setq ss (ssname ppp wcy))
  13.       (setq s (cdr (assoc 0 (setq e (entget ss)))))
  14.         (if (= "DIMENSION" s)
  15.            (command "dim1" "new" "WWW" ss ""))
  16. ;          (command "pedit" ss "w" nw ""))
  17.       (prompt "Working...")
  18.       (setq wcy (1+ wcy))
  19.     )
  20. )
  21. (defun C:WSCALE1 ( )
  22.   (setq ppp (ssget))
  23.   (setq nw (getreal "enter new width <0.5>:"))
  24.     (if (null nw) (setq nw 0.5))
  25.   (setq nw (* tb 100 nw))
  26.   (setq se (getvar "elevation"))
  27.   (setq st (getvar "thickness"))
  28.   (setq wcy 0 n (sslength ppp))
  29.     (while (< wcy n)
  30.       (setq ss (ssname ppp wcy))
  31.       (setq s (cdr (assoc 0 (setq e (entget ss)))))
  32.         (if (= "POLYLINE" s)
  33.            (command "pedit" ss "w" nw ""))
  34.         (if (or (= "LINE" s) (= "ARC" s))
  35.            (command "pedit" ss "y" "w" nw ""))
  36.         (if (= "CIRCLE" s) (cirtopl))
  37.         (if (= "TRACE" s) (tratopl))
  38.       (prompt "Working...")
  39.       (setq wcy (1+ wcy))
  40.     )
  41.   (setvar "elevation" se)
  42.   (setvar "thickness" st)
  43.   (setvar "highlight" 1)
  44. )
  45. (defun tratopl ( )
  46.   (entdel ss)
  47.   (setq p1 (cdr (assoc 38 e)))
  48.     (if (null p1) (setvar "elevation" 0.0) (setvar "elevation" p1))
  49.   (setq p2 (cdr (assoc 39 e)))
  50.     (if (null p2) (setvar "thickness" 0.0) (setvar "thickness" p2))
  51.   (setq p1 (cdr (assoc 10 e)) p2 (cdr (assoc 11 e)))
  52.   (setq p01 (list (* (+ (car p1) (car p2)) 0.5)
  53.                  (* (+ (cadr p1) (cadr p2)) 0.5)))
  54.   (setq p1 (cdr (assoc 12 e)) p2 (cdr (assoc 13 e)))
  55.   (setq p23 (list (* (+ (car p1) (car p2)) 0.5)
  56.                  (* (+ (cadr p1) (cadr p2)) 0.5)))
  57.   (command "pline" p01 "w" nw nw p23 "")
  58. )
  59. (defun cirtopl (/ p1 r)
  60.   (entdel ss)
  61.   (setq p1 (cdr (assoc 38 e)))
  62.     (if (null p1) (setvar "elevation" 0.0) (setvar "elevation" p1))
  63.   (setq r (cdr (assoc 39 e)))
  64.     (if (null r) (setvar "thickness" 0.0) (setvar "thickness" r))
  65.   (setq p1 (cdr (assoc 10 e)) r (cdr (assoc 40 e)))
  66.   (command "pline" (polar p1 0.0 r)
  67.     "w" nw nw "a" "ce" p1 "angle" 180 "close")
  68. )
  69.