;;; - ------------------------------------------------------------------------------ - ;
;;; -                T O O L - A C M - T S T Y L E C L E A N E R                     - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Beschreibung : Standardisierung der Textstile einer  Zeichnung                 - ;
;;; - Befehle      : TSTYLECLEANER                                                   - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Plattform    : AutoCAD 2008 oder höher                                         - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - letzte Änderung am : 01.11.2025                                                - ;
;;; -              durch : Thomas Krüger   (tk@cad-od.de)                            - ;
;;; - ------------------------------------------------------------------------------ - ;
(vl-load-com)
;;; - ------------------------------------------------------------------------------ - ;
(defun C:TSTYLECLEANER(/ TEXTSTYLE-MAKE TEXTSTYLE-CLEAN-ALL ) 
  ;;; - ---------------------------------------------------------------------------- - ;
  (defun TEXTSTYLE-MAKE(PROPS / OBJEKTDATEN TSTYLE)
    (if(not(and(=(type (cdr(assoc   "NAME" PROPS)))'STR)
               (numberp(cdr(assoc "BREITE" PROPS)))
               (=(type (cdr(assoc   "FONT" PROPS)))'STR)
           )
       )
      (if(=(getvar "CMDECHO")1)(prompt"\nFehler : Ungültige Textstildaten.."))
      (if (tblobjname "STYLE" (cdr(assoc "NAME" PROPS)))
        (progn
          (setq OBJEKTDATEN (entget(tblobjname "STYLE" (cdr(assoc "NAME" PROPS)))'("*")))
          (if(setq TSTYLE(entmod (list  (assoc -1 OBJEKTDATEN)
                                       '(0 . "STYLE")
                                        (assoc 330 OBJEKTDATEN)
                                        (assoc 5   OBJEKTDATEN)
                                       '(100 . "AcDbSymbolTableRecord")
                                       '(100 . "AcDbTextStyleTableRecord")
                                        (cons 2   (cdr(assoc "NAME" PROPS)))
                                       '(70 . 0)
                                       '(40 . 0.0)
                                        (cons 41 (cdr(assoc "BREITE" PROPS)))
                                       '(50 . 0.0)
                                       '(71 . 0)
                                       '(42 . 2.2)
                                        (cons 3  (cdr(assoc "FONT" PROPS)))
                                       '(4 . "")
                                 )
                                 
                         )
             )
            (progn
              (if(=(getvar "CMDECHO")1)
                (prompt (strcat"\nTextstil modifiziert :" (cdr(assoc "NAME" PROPS))))
              )  
              TSTYLE
            )
          )  
        )
        (progn
          (if (setq TSTYLE(entmake(list'(0 . "STYLE")  
                                       '(100 . "AcDbSymbolTableRecord")
                                       '(100 . "AcDbTextStyleTableRecord")
                                        (cons 2  (cdr(assoc "NAME" PROPS)))
                                       '(70 . 0)
                                       '(40 . 0.0)
                                        (cons 41 (cdr(assoc "BREITE" PROPS)))
                                       '(50 . 0.0)
                                       '(71 . 0)
                                       '(42 . 2.2)
                                        (cons 3  (cdr(assoc "FONT" PROPS)))
                                       '(4 . "")
                                  )
                          )
              )
            (progn
              (if(=(getvar "CMDECHO")1)
                (prompt (strcat"\nTextstil angelegt :" (cdr(assoc "NAME" PROPS))))
              )  
              TSTYLE
            )
          )  
        )
      )
    )  
  )
  ;;; - ---------------------------------------------------------------------------- - ;
  (defun TEXTSTYLE-CLEAN-ALL( NEWSTYLELIST STANDARDSHX STANDARDTTF
                            / BLOCK TS LISTE STYLE LAYOUT ITEM ATTRIBUTLIST ATTRIBUT
                              COUNT
                            )
    (defun TEXTSTYLE-CHANGE( ITEM / OLDSTYLE FONT STYLE)
      (cond
         ((and(member (strcase(vla-get-ObjectName ITEM))
                    (mapcar 'strcase '("AcDbText" "AcDbMText" "AcDbAttributeDefinition"
                                       "AcDbAttribute")
                    )
              )                
              (vlax-property-available-p ITEM 'StyleName 'T)
              (setq OLDSTYLE (vla-get-Stylename ITEM))
              (setq FONT (cdr(assoc (strcase OLDSTYLE) LISTE)))
              (or(setq STYLE (cdr(assoc(strcase FONT) NEWSTYLELIST)))
                 (setq STYLE (cdr(assoc(strcat(strcase FONT)".SHX") NEWSTYLELIST)))
                 (setq STYLE (cdr(assoc(strcat(strcase FONT)".TTF") NEWSTYLELIST)))
                 (if(vl-string-search ".TTF" (strcase FONT))
                   (setq STYLE STANDARDTTF)
                 )
                 (if(vl-string-search ".SHX" (strcase FONT))
                   (setq STYLE STANDARDSHX)
                 )
              )   
              (/=(strcase OLDSTYLE)(strcase STYLE))
          )            
            (if(not(vl-catch-all-error-p
                     (vl-catch-all-apply'vla-put-Stylename (list ITEM STYLE))
                   )
               )
              (setq COUNT (1+ COUNT))
            )        
         )
         ((and(wcmatch(strcase(vla-get-ObjectName ITEM))"*DIMENSION*")                  
              (vlax-property-available-p ITEM 'TextStyle 'T)
              (setq OLDSTYLE (vla-get-TextStyle ITEM))
              (setq FONT (cdr(assoc (strcase OLDSTYLE) LISTE)))                      
              (or(setq STYLE (cdr(assoc(strcase FONT) NEWSTYLELIST)))
                 (if(vl-string-search ".TTF" (strcase FONT))
                   (setq STYLE STANDARDTTF)
                 )
                 (if(vl-string-search ".SHX" (strcase FONT))
                   (setq STYLE STANDARDSHX)
                 )
              )   
              (/=(strcase OLDSTYLE)(strcase STYLE))
          )
            (if(not(vl-catch-all-error-p
                     (vl-catch-all-apply'vla-put-Stylename (list ITEM STYLE))
                   )
               )
              (setq COUNT (1+ COUNT))
            )        
         )
       )  
    )  
    (setq COUNT 0)
    (if (and(or (not NEWSTYLELIST)(=(type NEWSTYLELIST)'LIST))
            (or (and (=(type STANDARDSHX)'STR)(tblobjname "STYLE" STANDARDSHX))
                (setq STANDARDSHX "STANDARD")
            )
            (or (and (=(type STANDARDTTF)'STR)(tblobjname "STYLE" STANDARDTTF))
                (setq STANDARDTTF "STANDARD")
            )
        )
      (progn
        (while (setq TS(tblnext "STYLE" (null TS)))
          (setq LISTE (cons (cons (strcase(cdr(assoc 2 TS)))(strcase(cdr(assoc 3 TS)))) LISTE))
        )  
        (vlax-for LAYOUT (vla-get-layouts(vla-get-activedocument(vlax-get-acad-object)))    
          (vlax-for ITEM (setq BLOCK (vla-get-Block LAYOUT))
            (if (member(strcase(vla-get-ObjectName ITEM)) '("ACDBBLOCKREFERENCE" "ACDBMINSERTBLOCK"))
              (if(and(=(vla-get-hasattributes ITEM) :vlax-true)
                     (setq ATTRIBUTLIST (vlax-variant-value(vla-getattributes ITEM)))
                     (=(vlax-safearray-get-dim ATTRIBUTLIST)1)
                     (<=(vlax-safearray-get-l-bound ATTRIBUTLIST 1)
                        (vlax-safearray-get-u-bound ATTRIBUTLIST 1)
                     )
                     (setq ATTRIBUTLIST(vlax-safearray->list ATTRIBUTLIST))
                 )
                
                (foreach ATTRIBUT ATTRIBUTLIST
                  (TEXTSTYLE-CHANGE ATTRIBUT)
                )  
              )
            )  
            (TEXTSTYLE-CHANGE ITEM)
          )  
        )                                            
        (vlax-for BLOCK (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object)))
          (vlax-for ITEM BLOCK          
            (if (member(strcase(vla-get-ObjectName ITEM)) '("ACDBBLOCKREFERENCE" "ACDBMINSERTBLOCK"))
              (if(and(=(vla-get-hasattributes ITEM) :vlax-true)
                     (setq ATTRIBUTLIST (vlax-variant-value(vla-getattributes ITEM)))
                     (=(vlax-safearray-get-dim ATTRIBUTLIST)1)
                     (<=(vlax-safearray-get-l-bound ATTRIBUTLIST 1)
                        (vlax-safearray-get-u-bound ATTRIBUTLIST 1)
                     )
                     (setq ATTRIBUTLIST(vlax-safearray->list ATTRIBUTLIST))
                 )
                (foreach ATTRIBUT ATTRIBUTLIST(TEXTSTYLE-CHANGE ATTRIBUT))  
              )
            )  
            (TEXTSTYLE-CHANGE ITEM)
          )  
        )
        (vla-put-ActiveTextstyle
          (vla-get-activedocument(vlax-get-acad-object))
          (vla-ITEM (vla-get-textstyles
                      (vla-get-activedocument(vlax-get-acad-object))
                    )
                    STANDARDSHX
          )          
        )
        (vlax-for ITEM (vla-get-textstyles
                         (vla-get-activedocument(vlax-get-acad-object))
                       )
          (vl-catch-all-error-p
            (vl-catch-all-apply'vla-delete(list ITEM))
          )
        )  
        (vla-regen(vla-get-activedocument (vlax-get-acad-object)) acAllViewports)
        (if(=(getvar "CMDECHO")1)
          (prompt (strcat"\n" (itoa COUNT) " Textobjekt modifiziert\n"))
        )  
      )
    )
  )  
  ;;; - --------------------------------------------------------------------------------- - ;
  ;;; - Hier die gewünschten Einstellungen vornehmen ...................................... ;
  ;;; - 1. anzulegenden Textstile:                   ...................................... ;
  ;;; - wobei die Vorgaben in Form einer Liste übergeben werden :
  (TEXTSTYLE-MAKE '(("NAME" . "ISOCP-SHX-B090")  ("BREITE" . 0.9 )("FONT" .    "isocp.shx")))
  (TEXTSTYLE-MAKE '(("NAME" . "SWIS721BT-B085")  ("BREITE" . 0.85)("FONT" .   "swissb.ttf")))
  (TEXTSTYLE-MAKE '(("NAME" . "ACDINGDT")        ("BREITE" . 1.0 )("FONT" .    "amgdt.shx")))
  (TEXTSTYLE-MAKE '(("NAME" . "ACDINTS")         ("BREITE" . 1.0 )("FONT" .    "isocp.shx")))
  (TEXTSTYLE-MAKE '(("NAME" . "STANDARD")        ("BREITE" . 0.8 )("FONT" .    "isocp.shx")))
  (princ "\n")
  ;;; - 2. TextFontabhänging zu ändernde Textstile 
  (TEXTSTYLE-CLEAN-ALL
    ;;( verwendeter Font . Neuer Stil      )
    '(("ISOCP.SHX"       . "ISOCP-SHX-B090")      
      ("ROMANS.SHX"      . "ISOCP-SHX-B090")
      ("TXT.SHX"         . "ISOCP-SHX-B090")
      ("ARIAL.TTF"       . "SWIS721BT-B085")
      ("SWISS.TTF"       . "SWIS721BT-B085")
      ("SWISSB.TTF"      . "SWIS721BT-B085")
     )
    ;;;; Standardstil für shx-Fonts
    "ISOCP-SHX-B09" 
    ;;;; Standardstil für ttf-Fonts
    "SWIS721BT-B085"
  )    
  (princ)
)
;;; - ------------------------------------------------------------------------------- - ;
(defun ACM-TSTYLECLEANER:INFO() 
  (mapcar
    'princ
    (list
      "\n\n"
      "\nACM-TSTYLECLEANER : Standardisierung der Textstile und Texte" 
      "\n=============== "
      "\n(C) Thomas Krüger 2025" 
      "\nE-Mail: tk@cad-od.de"
      "\nBefehlszeilenaufruf : TSTYLECLEANER\n"   
    )
  )
  (princ)  
)
;;; - ------------------------------------------------------------------------------- - ;
(ACM-TSTYLECLEANER:INFO)
(princ)
