;| acmLinetypeLoader

Lädt Linientypen durch Eingabe des Namens unabhängig von der Linientypdatei.
Das Tool durchsucht alle verfügbaren Linientypdateien selbständig.
Durch Eingabe von * werden alle Linientypen geladen, die von AutoCAD gefunden werden können.

Plattform: ab AutoCAD 2024

Copyright
Markus Hoffmann, www.CADmaro.de

Februar, 2025
|;
(defun c:acmLinetypeLoader (/ lLtypes sLtype)
  (mx:Init)
  (mapcar
    'mx:PrintList
    (setq lLtypes
           (mx:CollectLtypes)
    )
  )
  (textscr)
  (if
    (setq
      sLtype
       (mx:GetString
         "\nLinientypname, der geladen werden soll oder Weitere oder * für alle: "
         "Weitere/*"
       )
    )
     (mxFind&LoadLIt sLtype (mx:AvailableLTypeFiles))
  )
  (mx:Reset)
  (princ)
)

 ;| mxFind&LoadLIt

Linientypname abfragen und Entscheidungen finden, Ltyp laden
|;
(defun mxFind&LoadLIt (sLtype lLinFiles / file)
  (cond
    ;;
    ;; wenn nur bestätigt wurde
    ((or
       (= "*" sLtype)
       (= "Weitere/*" sLtype)
     )
;;;      (mapcar 'mx:LoadLinetype
;;;              (apply 'append (mapcar 'cdr lLtypes))
;;;      )
     (mapcar
       '(lambda (s)
          (mx:LoadLinetype
            s
            lLinFiles
          )
        )
       (apply 'append (mapcar 'cdr lLtypes))
     )
    )
    ;;
    ;; wenn explizit "Weitere" gewählt wurde
    ((or
       (= "WEITERE" (strcase sLtype))
       (= "W" sLtype)
       (= "w" sLtype)
     )
      (setq file
             (getfiled
               "\nLinientypdatei wählen"
               ""
               "lin"
               16
             )
      )
      (mapcar
        '(lambda (s)
           (mx:LoadLinetype s (list file))
         )
        (mx:ExtractLTypenames file)
      )
      (princ
        (strcat
          "\nAlle Linientypen aus "
          file
          " wurden geladen."
        )
      )
    )
    ;;
    ;; Wenn der Name nicht bekannt ist
    ((not
       (member
         sLtype
         (apply 'append (mapcar 'cdr lltypes))
       )
     )
     (alert
       (strcat
         "\n Unbekannter Linientypname: "
         sLtype
         "!"
       )
     )
    )
    ;;
    ;; Ansonsten scheint der Name zu passen, also laden
    ('T
     (mx:LoadLinetype sLtype lLinFiles)
     (setvar "CELTYPE" sLtype)
    )
  )
)

 ;| mx:GetString

Gestring-Funktion mit Default
|;
(defun mx:Getstring (sMsg sDefault / sResult)
  (setq sResult
         (getstring (strcat "\n" sMsg " [" sDefault "]: "))
  )
  (if (/= sResult "")
    sResult
    sDefault
  )
)

 ;| mx:LoadLinetype

Linientyp laden, wenn möglich
|;
(defun mx:LoadLinetype (strLType lLinFiles / lLinFiles)
  (if
    (mx:LTypeLoaded? strLType)          ; prüfen, ob schon geladen
     (princ
       (strcat "\nLinientyp " strLType " ist bereits geladen.")
     )
     (progn
       (while (not (mx:LTypeLoaded? strLType))
         (vl-catch-all-error-p
           (vl-catch-all-apply
             'vla-load
             (list
               (vla-get-LineTypes
                 oAD
               )
               strLType
               (car lLinFiles)
             )
           )
         )
         (setq lLinFiles (cdr lLinFiles))
       )
       (princ
         (strcat
           "\nLinientyp "
           strLType
           " wurde geladen."
         )
       )
     )
  )
  (if
    (not (mx:LTypeLoaded? strLType))
     (princ
       (strcat
         "\nDer Linientyp "
         strLType
         " konnte nicht gefunden und/oder geladen werden!"
       )
     )
  )
  strLType
)

 ;| mx:LTypeLoaded?

prüft, ob der übergebene Linientyp bereits geladen ist
|;
(defun mx:LTypeLoaded? (strLType)
  (not
    (vl-catch-all-error-p
      (vl-catch-all-apply
        'vla-item
        (list
          (vlax-get-property
            oAD
            'LineTypes
          )
          strLType
        )
      )
    )
  )
)

 ;| mx:CollectLtypes

alle ladbaren Linientypen listen
|;
(defun mx:CollectLtypes (/ l)
  (mapcar
    '(lambda (s)
       (setq l
              (cons
                (strcat "\n" s)
                (reverse
                  (mx:ExtractLTypenames s)
                )
              )
       )
     )
    (mx:AvailableLTypeFiles)
  )
)

 ;| mx:ExtractLTypenames

Linientypennamen extrahieren
|;
(defun mx:ExtractLTypenames (sFName / f sReadLine l)
  (if
    (setq f (open sFName "r"))
     (progn
       (while (setq sReadLine (read-line f))
         (if (= "*" (substr sReadLine 1 1))
           (setq l
                  (cons
                    (substr
                      (car (mx:String2List sReadLine ","))
                      2
                    )
                    l
                  )
           )
         )
       )
       (close f)
     )
  )
  l
)

 ;| mx:PrintList

Liste aus Strings Zeile für Zeile drucken
|;
(defun mx:PrintList (l)
  (mapcar
    '(lambda (s)
       (princ (strcat "\n" s))
     )
    l
  )
  (princ)
)

 ;| mx:AvailableLTypeFiles

Liste der LIN-Dateien im Supportpfad
|;
(defun mx:AvailableLTypeFiles (/ l)
  (mapcar
    '(lambda (x)
       (setq l
              (append
                (mapcar
                  '(lambda (s)
                     (strcat x "\\" s)
                   )
                  (vl-directory-files
                    x
                    "*.lin"
                    1
                  )
                )
                l
              )
       )
     )
    (mx:String2List
      (mx:GetSupportPath)
      ";"
    )
  )
  l
)

 ;| mx:GetSupportPath

liest die Ordner des Supportpfads aus
|;
(defun mx:GetSupportPath ()
  (vla-get-SupportPath
    (vla-get-Files
      (vla-get-Preferences oA)
    )
  )
)

 ;| mx:String2List

teilt einen String in eine Liste aus Einzelstrings
|;
(defun mx:String2List (str strToken / intPos intToken+1 lst)
  (setq intToken+1 (1+ (strlen strToken)))
  (while
    (setq intPos (vl-string-search strToken str))
     (setq lst (cons (substr str 1 intPos) lst)
           str (substr str (+ intPos intToken+1))
     )
  )
  (reverse (cons str lst))
)

 ;| mx:Init

Initialisierung
|;
(defun mx:Init ()
  (vl-load-com)
  (setq oA (vlax-get-acad-object))
  (setq oAD
         (vlax-get-property
           oA
           'ActiveDocument
         )
  )
  (setq iECHO (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setq errorMX *error*
        *error* mx:Error
  )
  (vlax-invoke-method oAD 'EndUndomark)
  (vlax-invoke-method oAD 'StartUndomark)
)

 ;| mx:Reset

Zurücksetzen
|;
(defun mx:Reset ()
  (setvar "CMDECHO" iECHO)
  (vlax-invoke-method oAD 'EndUndomark)
  (vlax-release-object oAD)
  (vlax-release-object oA)
  (setq *error* errorMX)
  (mapcar
    '(lambda (arg)
       (set
         arg
         'nil
       )
     )
    (list 'errorMX 'iEcho 'oAD 'oA)
  )
)

 ;| mx:Error

Errorfunktion
|;
(defun mx:Error (s)
  (print (strcat "Fehler " s))
  (command-s)
  (command-s "_.undo" "_back")
  (mx:Reset)
  (princ)
)

;;; Kurzbefehl
(defun c:acmLtL () (c:acmLinetypeLoader))

;; Feedback beim Laden
(princ
  "\nacmLinetypeLoader.lsp wurde geladen. Copyright M.Hoffmann, www.CADmaro.de.
Start mit \"acmLtL\" oder \"acmLinetypeLoader\"."
)
(princ)