home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p047 / 4.ddi / TY / PPP.LSP < prev    next >
Encoding:
Text File  |  1990-12-04  |  2.9 KB  |  97 lines
  1. ;********************
  2. ;**** TY\PPP.LSP ****
  3. ;********************  8910 CD
  4. (defun C:PPP ( )
  5.   (setq ppp (ssget))
  6.   (setq wcy 1)
  7.   (while wcy
  8. ;   (setq mode (getint "\n 0.mppp/1.cstrh/2.cstra/3.cstrw/
  9. ;4.LAyer/5.Color/6.LType/7.Elev/8.Thickness/9.explode <or RETRUN for none>:"))
  10.     (setq mode (getint "\n 0.mppp/1.cstrh/2.cstra/3.cstrw/
  11. 4.LA/5.Col/6.LT/7.Elev/8.Th/9.explode/10.blk:"))
  12.     (if (null mode) (setq wcy nil))
  13.     (if (= mode 0) (setq ppp (ssget)))
  14.     (if (= mode 1) (csh))
  15.     (if (= mode 2) (csa))
  16.     (if (= mode 3) (csw))
  17.     (if (= mode 4) (progn (setq dh (getstring "New layer:"))
  18.      (command "change" ppp "" "lay" dh "")))
  19.     (if (= mode 5) (progn (setq dh (getstring "New color:"))
  20.      (command "change" ppp "" "p" "color" dh "")))
  21.    (if (= mode 6) (progn (setq dh (getstring "New ltype<bylayer>:"))
  22.      (if (= dh "") (setq dh "bylayer"))
  23.      (command "change" ppp "" "p" "ltype" dh "")))
  24.     (if (= mode 7) (progn (setq dh (getreal "New elevation:"))
  25.      (command "change" ppp "" "p" "elev" dh "")))
  26.     (if (= mode 8) (progn (setq dh (getreal "New thickness:"))
  27.      (command "change" ppp "" "p" "th" dh "")))
  28.     (if (= mode 9) (exp))
  29.     (if (= mode 10) (eblk))
  30.   )
  31. )
  32. ;------------
  33. (defun csh ( )
  34.   (setq nsh (getreal "enter nsh <3.5>:"))
  35.   (if (null nsh) (setq nsh 3.5))
  36.   (setq nsh (* 100 tb nsh))
  37.   (setq wxr 0 n (sslength ppp))
  38.   (while (< wxr n)
  39.     (setq ss (entget (ssname ppp wxr)))
  40.     (if (= (cdr (assoc 0 ss)) "TEXT") (progn
  41.     (setq ss (subst (cons 40 nsh) (assoc 40 ss) ss))
  42.     (entmod ss)))
  43.     (setq wxr (1+ wxr))
  44.   )
  45. )
  46. ;------------
  47. (defun csa ( )
  48.   (setq nsa (getangle "enter nsa <0.0>:"))
  49.   (if (null nsa) (setq nsa 0.0))
  50.   (setq wxr 0 n (sslength ppp))
  51.   (while (< wxr n)
  52.     (setq ss (entget (ssname ppp wxr)))
  53.     (if (= (cdr (assoc 0 ss)) "TEXT") (progn
  54.     (setq ss (subst (cons 50 nsa) (assoc 50 ss) ss))
  55.     (entmod ss)))
  56.     (setq wxr (1+ wxr))
  57.   )
  58. )
  59. ;------------
  60. (defun csw ( )
  61.   (setq nsw (getreal "enter nsw <1.0>:"))
  62.   (if (null nsw) (setq nsw 1.0))
  63.   (setq wxr 0 n (sslength ppp))
  64.   (while (< wxr n)
  65.     (setq ss (entget (ssname ppp wxr)))
  66.     (if (= (cdr (assoc 0 ss)) "TEXT") (progn
  67.     (setq ss (subst (cons 41 nsw) (assoc 41 ss) ss))
  68.     (entmod ss)))
  69.     (setq wxr (1+ wxr))
  70.   )
  71. )
  72. ;------------
  73. (defun exp ( )
  74.   (setq wxr 0 n (sslength ppp))
  75.   (while (< wxr n)
  76.     (setq ss (ssname ppp wxr))
  77.     (setq s (cdr (assoc 0 (entget ss))))
  78.     (if (or (= s "INSERT") (= s "POLYLINE") (= s "DIMENSION"))
  79.       (command "explode" ss))
  80.     (setq wxr (1+ wxr))
  81.   )
  82. )
  83. ;------------
  84. (defun eblk (/ k s0 s2)
  85.   (setq new (strcase (getstring "new block name:")))
  86.   (setq k 0 n (sslength ppp))
  87.   (while (< k n)
  88.     (setq ss (ssname ppp k))
  89.     (setq s0 (cdr (assoc 0 (setq s2 (entget ss)))))
  90.     (if (and (= s0 "INSERT") (/= (cdr (assoc 2 s2)) new))
  91.       (progn (setq s2 (subst (cons 2 new) (assoc 2 s2) s2))
  92.         (entmod s2)))
  93.     (setq k (1+ k))
  94.   )
  95. )
  96. (princ)
  97.