; MTEXT Bereinigen durch Entfernen von Stilüberschreibungen
; von Flaschenpost  ( cad.de ) - 31.01.2005
;
; enthält Funktionen mit freundl. Unterstützung der Seiten
; www.autolisp.mapcar.net/index.html
;
; Der gewählte Stil wird entfernt. Es genügt die Eingabe 
; von "Romans" oder z.B. "Arial" (für alle Arial-Schriften),
; soll nur Arial Black entfernt werden, dann "Arial Black"
;
; Vor Verwendung auf Eignung prüfen ! 
;
; Der Stilname selbst darf in den Texten nicht vorkommen.
; Textinhalte nach Änderung überprüfen !



(defun str-pos(str c / i l ls lc)
  (setq i 1)
  (setq ls(strlen str))
  (setq lc(strlen c))
  (setq l(1+(- ls lc)))
  (while(and(<= i l)(/=(substr str i lc)c))
    (setq i(1+ i))
  )
  (if(<= i l)i)
)

(defun str-ipos(str c / )
  (str-pos(strcase str)(strcase c))
)


(defun str-remove(str pos n / )
  (strcat
    (substr str 1(1- pos))
    (substr str(+ pos n))
  )
)


(defun str-subst(str neu alt / i la str2)
  (setq i 1)
  (setq la(strlen alt))
  (setq str2 "")
  (while(<= i(strlen str))
    (if
      (=(substr str i la)alt)
      (progn
        (setq str2(strcat str2 neu))
        (setq i(+ i la))
      )
      (progn
        (setq str2(strcat str2(substr str i 1)))
        (setq i(1+ i))
      )
    )
  )
  str2
)


(defun stil_austausch 
  (/ stiln_neu mt_wahl nr n txt_inh anfpos semi anfbl eklam aklam kl_txt kl_txt1 kl_txt2) 


(if (or (= stilname nil)(= stilname "")) 
    (setq stilname (getstring "\nStilname, der entfernt werden soll: "))
    (progn    
    (if (/= (setq stiln_neu (getstring 
            (strcat "\nStilname für Entfernung '" stilname "' ändern? [weiter mit Enter]: "))) "") 
        (setq stilname stiln_neu)
    )            
    )
)


;(setq stilname (strcat "\f" stilname))

(print "Mtext wählen :")
(while (= (setq mt_wahl (ssget (list '(0 . "MTEXT")(cons 1 (strcat"*" stilname "*"))))) nil)
          (progn
          (print "Kein Mtext gewählt oder Stilname nicht vorhanden")
          (if (/= (setq stiln_neu (getstring 
              (strcat "\nStilname für Entfernung '" stilname "' ändern? [weiter mit Enter]: "))) "") 
              (setq stilname stiln_neu)
          )            
          );progn 
)   

  
 (setq nr -1)
 (repeat (sslength mt_wahl)
  
  (setq mtext  (entget (ssname mt_wahl (setq nr (1+ nr))) ))
  (setq txt_inh (cdr (assoc 1 mtext)))

 (while (/= (str-ipos txt_inh stilname) nil)
  
   (progn
   
   (setq anfpos (str-ipos txt_inh stilname))  
   (setq txt_inh (str-subst txt_inh (strcat "f" stilname)(strcat "F" stilname)) )  


   (setq n 1)
   (while (/= (substr txt_inh (- anfpos n) 1) "\f") (setq n (1+ n))  )
   (setq anfbl (- anfpos n))
   
   (setq n 1)
   (while (/= (substr txt_inh (+ anfpos n) 1) ";") (setq n (1+ n))  )
   (setq semi (+ anfpos n)) 
  
   (setq txt_inh_neu (str-remove txt_inh (1- anfbl) (+ (- semi anfbl)2)) )
   (setq txt_inh txt_inh_neu)
   ); progn
 );while


   ;Klammern bereinigen
   (while (/= (setq aklam (str-ipos txt_inh "{")) nil)
       (progn
       (setq eklam (str-ipos txt_inh "}"))
       (setq kl_txt (substr txt_inh aklam eklam)) 
       ;wenn Farbe, Unterstreichen, weiterer Text
       (if (= (or (wcmatch kl_txt "*\C*")
              (wcmatch kl_txt "*\L*")(wcmatch kl_txt "*\F*")(wcmatch kl_txt "*'\\f*")) T)
       (progn ; Klammern ersetzen
       (setq kl_txt1 (str-subst kl_txt "#~" "{"))
       (setq kl_txt2 (str-subst kl_txt1 "~#" "}"))
       (setq txt_inh (str-subst txt_inh kl_txt2 kl_txt))
       )
       (progn ; sonst Klammern löschen 
       (print "klammern werden gelöscht")
       (setq txt_inh (str-remove txt_inh aklam 1))    
       (setq txt_inh (str-remove txt_inh (1- eklam) 1))
       )
       ); if

      ); progn
   );while
   

   (setq txt_inh (str-subst txt_inh "{" "#~")); Klammern wieder einsetzen
   (setq txt_inh (str-subst txt_inh "}" "~#"))
 

  (setq mtext_neu (subst (cons 1 txt_inh)(assoc 1 mtext) mtext) ) 
  (entmod mtext_neu)
 )


);defun


(defun c:MTB ()
(stil_austausch)
)

;
(princ "\nMTEXT Bereinigen geladen, Start mit: MTB ")
(princ)