home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p047 / 4.ddi / TY / CHASTR.LSP < prev    next >
Encoding:
Text File  |  1990-05-27  |  7.9 KB  |  259 lines
  1. ;****** TY\CHASTR.LSP ****** 10-15-89 BJ
  2. (defun C:CHASTR ( )
  3.   (setq wcy 1)
  4.   (while wcy
  5. ;   (setq mode (getint "\n 0mppp/1c-zh/2c-za/3c-zw/4c-lay
  6.     (setq mode (getint "\n 1c-zh/2c-za/3c-zw/4c-lay/5c-color
  7.       6FD/7LJ/8CR*/9CR1/10PL/11c-str1/12c-str*:"))
  8.     (if (null mode) (setq wcy nil))
  9. ;   (if (null mode) (setq wcy nil) (mppp))
  10. ;   (if (= mode 0) (setq ppp (ssget)))
  11.     (if (= mode 1) (progn (mppp) (csh)))
  12.     (if (= mode 2) (progn (mppp) (csa)))
  13.     (if (= mode 3) (progn (mppp) (csw)))
  14.     (if (= mode 4) (progn (setq dh (getstring "New layer:"))
  15.       (command "change" ppp "" "lay" dh "")))
  16.     (if (= mode 5) (progn (setq dh (getstring "New color:"))
  17.       (command "change" ppp "" "p" "color" dh "")))
  18.     (if (= mode 6) (fd))
  19.     (if (= mode 7) (lj))
  20.     (if (= mode 8) (progn (mppp) (cr*)))
  21.     (if (= mode 9) (cr1))
  22.     (if (= mode 10) (progn (mppp) (pl)))
  23.     (if (= mode 11) (progn (mppp) (c-str1)))
  24.     (if (= mode 12) (progn (mppp) (c-str*)))
  25.   )
  26. )
  27. ;------------
  28. (defun mppp ( )
  29.   (if ppp (prompt "\n Made ppp <old>,") (prompt "\n Made ppp,"))
  30.   (setq new (ssget))
  31.   (if new (setq ppp new))
  32. ;   (if (null ppp) (setq ppp (ssget)))
  33. )
  34. ;------------
  35. (defun csh ( )
  36. ;   (if (null ppp) (setq ppp (ssget)))
  37.   (setq nsh (getreal "enter nsh <3.5>:"))
  38.   (if (null nsh) (setq nsh 3.5))
  39.   (setq nsh (* 100 tb nsh))
  40.   (setq wxr 0 n (sslength ppp))
  41.   (while (< wxr n)
  42.     (setq ss (entget (ssname ppp wxr)))
  43.     (if (= (cdr (assoc 0 ss)) "TEXT") (progn
  44.     (setq ss (subst (cons 40 nsh) (assoc 40 ss) ss))
  45.     (entmod ss)))
  46.     (setq wxr (1+ wxr))
  47.   )
  48. )
  49. ;------------
  50. (defun csa ( )
  51. ;   (if (null ppp) (setq ppp (ssget)))
  52.   (setq nsa (getangle "enter nsa <0.0>:"))
  53.   (if (null nsa) (setq nsa 0.0))
  54.   (setq wxr 0 n (sslength ppp))
  55.   (while (< wxr n)
  56.     (setq ss (entget (ssname ppp wxr)))
  57.     (if (= (cdr (assoc 0 ss)) "TEXT") (progn
  58.     (setq ss (subst (cons 50 nsa) (assoc 50 ss) ss))
  59.     (entmod ss)))
  60.     (setq wxr (1+ wxr))
  61.   )
  62. )
  63. ;------------
  64. (defun csw ( )
  65. ;   (if (null ppp) (setq ppp (ssget)))
  66.   (setq nsw (getreal "enter nsw <1.0>:"))
  67.   (if (null nsw) (setq nsw 1.0))
  68.   (setq wxr 0 n (sslength ppp))
  69.   (while (< wxr n)
  70.     (setq ss (entget (ssname ppp wxr)))
  71.     (if (= (cdr (assoc 0 ss)) "TEXT") (progn
  72.     (setq ss (subst (cons 41 nsw) (assoc 41 ss) ss))
  73.     (entmod ss)))
  74.     (setq wxr (1+ wxr))
  75.   )
  76. )
  77. ;------------
  78. (defun fd ( / k pt)
  79.   (setq sss (entget (setq sss0 (car (entsel "select string:")))))
  80.   (if (= (cdr (assoc 0 sss)) "TEXT") (progn
  81.     (setq s12 (cdr (assoc 1 sss)))
  82.     (setq k (getint "enter int k:"))
  83.     (if (< k 0) (setq k (+ (strlen s12) k)))
  84.     (setq s1 (substr s12 1 k))
  85.     (setq s2 (substr s12 (+ k 1)))
  86.     (setq sss (subst (cons 1 s1) (cons 1 s12) sss))
  87.     (entmod sss)
  88.     (setq pt (cdr (assoc 10 sss)))
  89.     (command "copy" sss0 "" pt
  90.       (setq pt (polar pt (cdr (assoc 50 sss)) 
  91.       (* k (cdr (assoc 40 sss)) (cdr (assoc 41 sss))))))
  92.    (setq sss (entget (ssname (ssget "last") 0)))
  93.    (setq s12 (assoc 1 sss))
  94.    (setq sss (subst (cons 1 s2) s12 sss))
  95.    (entmod sss)
  96.   ))
  97.   (princ)
  98. )
  99. ;-------------------
  100. (defun cr* ( / k)
  101.     (setq -s- (getstring "enter string for CR:"))
  102.     (setq k (getint "enter int k <-1,0,1...>:"))
  103.   (setq wxr 0 n (sslength ppp))
  104.   (while (< wxr n)
  105.     (setq es (entget (setq e (ssname ppp wxr))))
  106.     (if (= (cdr (assoc 0 es)) "TEXT") (progn
  107.     (setq s (cdr (assoc 1 es)))
  108.     (if (< k 0) (setq k (+ (strlen s) k -1)))
  109.     (setq s1 (substr s 1 k))
  110.     (setq s2 (substr s (+ k 1)))
  111.     (setq ns (strcat s1 -s- s2))
  112.     (setq es (subst (cons 1 ns) (assoc 1 es) es))
  113.     (entmod es)))
  114.     (setq wxr (1+ wxr))
  115.   )
  116.   (princ)
  117. )
  118. ;-------------------
  119. (defun cr1 ( / k pt)
  120.   (setq sss (entget (setq sss0 (car (entsel "select string:")))))
  121.   (if (= (cdr (assoc 0 sss)) "TEXT") (progn
  122.     (setq s12 (cdr (assoc 1 sss)))
  123.     (setq k (getint "enter int k:"))
  124.     (if (< k 0) (setq k (+ (strlen s12) k)))
  125.     (setq s1 (substr s12 1 k))
  126.     (setq s2 (substr s12 (+ k 1)))
  127.     (setq s1-2 (getstring "enter string for CR:"))
  128.     (if (= s1-2 "") (setq s1-2 " "))
  129.     (setq sss (subst (cons 1 (strcat s1 s1-2 s2)) (cons 1 s12) sss))
  130.     (entmod sss)
  131.   ))
  132.   (princ)
  133. )
  134. ;-------------------
  135. (defun lj ( )
  136.   (setq sss (entget (setq sss0 (car (entsel "\n forst string:")))))
  137.   (if (= (cdr (assoc 0 sss)) "TEXT") (progn
  138.     (setq s12 (cdr (assoc 1 sss)))
  139.     (setq wcy 1 ns12 s12)
  140.     (while wcy
  141.       (setq ss (entsel "\n next string <or RETURN for none>:"))
  142.       (if (= ss nil) (setq wcy nil) (lj01))
  143.     )
  144.     (setq sss (subst (cons 1 ns12) (cons 1 s12) sss))
  145.     (entmod sss)
  146.   ))
  147.   (princ)
  148. )
  149. (defun lj01 ( )
  150.   (setq ss (entget (setq ss0 (car ss))))
  151.   (redraw ss0 3)
  152. ; (entdel ss0)
  153.   (if (= (cdr (assoc 0 ss)) "TEXT") (progn
  154.     (setq ss (cdr (assoc 1 ss)))
  155.     (setq ns12 (strcat ns12 ss))
  156.     (redraw ss0 4)
  157.   ))
  158. )
  159. ;-------------------
  160. (defun pl ( )
  161. ; (if (null ppp) (setq ppp (ssget)))
  162.   (setq pt (getpoint "Start point:"))
  163.   (setq zh (getreal "enter zh <3.5>:"))
  164.   (if (null zh) (setq zh 3.5))
  165.   (setq zh (* 100 tb zh))
  166.   (setq kk (getreal "enter ZJ <2.0>:"))
  167.   (if (null kk) (setq kk 2.0))
  168.   (setq k 0 n (sslength ppp))
  169.   (while (< k n)
  170.     (setq ss (entget (setq ss0 (ssname ppp k))))
  171.     (if (= (cdr (assoc 0 ss)) "TEXT")
  172.       (command "text" (polar pt (* -0.5 pi) (* kk k zh))
  173.         zh 0.0 (cdr (assoc 1 ss))))
  174.     (setq k (1+ k))
  175.   )
  176. )
  177. ;-------------------
  178. (defun c-str* ( )
  179.   (setq wxr 0 n (sslength ppp))
  180.   (while (< wxr n)
  181.     (setq ss (entget (setq ss0 (ssname ppp wxr))))
  182.     (if (= (cdr (assoc 0 ss)) "TEXT") (progn
  183. ;    (redraw ss0 3)
  184. ;    (setq old (cdr (assoc 1 ss)))
  185.      (setq new (strcase (cdr (assoc 1 ss))))
  186. ;    (setq new (getstring (strcat "\n new string:")))
  187.      (if (/= new "") (setq ss (subst (cons 1 new) (assoc 1 ss) ss)))
  188. ;    (redraw ss0 4)
  189.      (entmod ss)))
  190.     (setq wxr (1+ wxr))
  191.   )
  192. )
  193. (defun c-str1 ( )
  194. ;   (if (null ppp) (setq ppp (ssget)))
  195.   (setq wxr 0 n (sslength ppp))
  196.   (while (< wxr n)
  197.     (setq ss (entget (setq ss0 (ssname ppp wxr))))
  198.     (if (= (cdr (assoc 0 ss)) "TEXT") (progn
  199.      (redraw ss0 3)
  200.      (setq old (cdr (assoc 1 ss)))
  201. ;    (setq new (getstring (strcat "\n new string<" old ">:")))
  202.      (setq new (getstring (strcat "\n new string:")))
  203.      (if (/= new "") (setq ss (subst (cons 1 new) (assoc 1 ss) ss)))
  204.      (redraw ss0 4)
  205.      (entmod ss)))
  206.     (setq wxr (1+ wxr))
  207.   )
  208. )
  209. ;(defun c-str1 (/ adj l n e os as ns st s nsl osl sl si chf chm)
  210. (defun c-str* ( )
  211. ; (if (null ppp) (setq ppp (ssget)))
  212.   (if ppp (progn
  213.   (setq osl (strlen (setq os (getstring "\n old string:" t))))
  214.   (setq nsl (strlen (setq ns (getstring "\n new string:" t))))
  215.   (setq l 0 chm 0 n (sslength ppp))
  216.   (setq adj
  217.      (cond ((/= osl nsl) (- nsl osl)) (T nsl)))
  218.   (while (< l n)
  219.     (if (= "TEXT" (cdr (assoc 0 (setq e (entget (ssname ppp l))))))
  220.     (progn
  221.        (setq chf nil si 1)
  222.        (setq s (cdr (setq as (assoc 1 e))))
  223.        (while (= osl (setq sl (strlen (setq st (substr s si osl)))))
  224.        (if (= st os) (progn
  225.           (setq s (strcat (substr s 1 (1-  si))
  226.             ns (substr s (+ si osl))))
  227.        (setq chf t) (setq si (+ si adj))
  228.      ))
  229.      (setq si (1+ si))
  230.      )
  231.      (if chf (progn 
  232.        (setq e (subst (cons 1 s) as e))
  233.        (entmod e)
  234.        (setq chm (1+ chm))
  235.      ))
  236.     )
  237.    )
  238.      (setq l (1+ l))
  239.    )
  240.   ))
  241.   (princ "Changed ") (princ chm) (princ " text lines.") (terpri)
  242. )
  243. ; (setq wxr 0 n (sslength ppp))
  244. ; (while (< wxr n)
  245. ;   (setq ss (entget (setq ss0 (ssname ppp wxr))))
  246. ;   (if (= (cdr (assoc 0 ss)) "TEXT") (progn
  247. ;    (redraw ss0 3)
  248. ;    (setq old (cdr (assoc 1 ss)))
  249. ;    (setq new (getstring (strcat "\n new string<" old ">:")))
  250. ;    (if (/= new "") (setq ss (subst (cons 1 new) (assoc 1 ss) ss)))
  251. ;    (redraw ss0 4)
  252. ;    (entmod ss)))
  253. ;   (setq wxr (1+ wxr))
  254. ; )
  255. ;)
  256. (defun C:CLEAN2 ( )
  257.   (setq atomlist (member 'C:CLEAN2 atomlist))
  258.   'DONE2)
  259.