;;;   Programm:      ACM-LAYERCHECK.LSP
;;;   Befehlsaufruf: ACM-LAYERCHECK
;;;   Funktion:      Layouts und Blöcke nach Objekten auf einem bestimmten Layer durchsuchen
;;;   Autor:         Gerhard Rampf
;;;                  Kundenspezifische Anpassungen für AutoCAD und ZWCAD
;;;                  Liebigstr. 3 A
;;;                  86399 Bobingen
;;;                  E-Mail: rampf@geracad.de
;;;   Datum:         18.08.2024
;;;   Plattform:     Alle AutoCAD-Versionen ab Version 2005
(defun c:acm-layercheck ( / lch16 lch61 lhc01 lhc02 lhc03 lhc04 lhc05 lhc06 lhc07 lhc08 lhc09 lhc10 lhc11 lhc12 lhc13 lhc14 lhc15 lhc16)
    (defun lhc01 (lch01 / )
      (if lch61 (setq *error* lch61))
      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
      (princ)
    )
    (defun lhc02 (lch02 lch03 / lch12 lch13 lch14 lch15 lch16 lch17 lch18 lch19)
      (setq lch12 (car lch02))
      (setq lch13 (cadr lch02))
      (setq lch14 1)
      (setq lch15 (vlax-get-acad-object))
      (setq lch16 (vla-get-ActiveDocument lch15))
      (setq lch17 (vla-get-Path lch16))
      (prompt "\n ")
      (prompt "\n***")
      (prompt "\nErgebnis der Layersuche: ")
      (prompt "\n ")
      (prompt (strcat "\nGesuchter Layer: " lch03 " "))
      (prompt (strcat "\nDokument: " (getvar "DWGNAME") " "))
      (prompt (strcat "\nPfad: " lch17 " "))
      (prompt "\n ")
        (if (> (setq lch18 (length lch12)) 0)
          (progn
            (if (= lch18 1)
              (prompt "\nGefunden in folgendem Layout: ")
              (prompt (strcat "\nGefunden in folgenden " (itoa lch18) " Layouts: "))
            )
            (while lch12
              (prompt (strcat "\n" (car lch12)))
              (setq lch12 (cdr lch12))
            )
          )
          (prompt "\nGesuchter Layer wurde in keinem Layout gefunden. ")
        )
      (prompt "\n ")
        (if (> (setq lch19 (length lch13)) 0)
          (progn
            (if (= lch19 1)
              (prompt "\nGefunden in folgendem Block: ")
              (prompt (strcat "\nGefunden in folgenden " (itoa lch19) " Blöcken: "))
            )
            (while lch13
              (prompt (strcat "\n" (car lch13)))
              (setq lch13 (cdr lch13))
            )
          )
          (prompt "\nGesuchter Layer wurde in keinem Block gefunden. ")
        )
      (prompt "\n***")
      (prompt "\n ")
    )
    (defun lhc03 (lch02 lch03 / lch12 lch13 lch14 lch15 lch16 lch17 lch20 lch21 lch18 lch19)
      (setq lch12 (car lch02))
      (setq lch13 (cadr lch02))
      (setq lch14 1)
      (setq lch15 (vlax-get-acad-object))
      (setq lch16 (vla-get-ActiveDocument lch15))
      (setq lch17 (vla-get-Path lch16))
        (while (findfile (setq lch20 (strcat lch17 "\\" "acm-Layercheck_" (itoa lch14) ".txt")))
          (setq lch14 (1+ lch14))
        )
        (if (/= (type (setq lch21 (vl-catch-all-apply 'open (list lch20 "w")))) 'VL-CATCH-ALL-APPLY-ERROR)
          (progn
            (vl-catch-all-apply 'write-line (list (strcat "Ergebnis der Layersuche vom " (lhc04 1)) lch21))
            (vl-catch-all-apply 'write-line (list "" lch21))
            (vl-catch-all-apply 'write-line (list (strcat "Gesuchter Layer: " lch03) lch21))
            (vl-catch-all-apply 'write-line (list (strcat "Dokument: " (getvar "DWGNAME")) lch21))
            (vl-catch-all-apply 'write-line (list (strcat "Pfad: " lch17) lch21))
            (vl-catch-all-apply 'write-line (list "" lch21))
              (if (> (setq lch18 (length lch12)) 0)
                (progn
                  (if (= lch18 1)
                    (vl-catch-all-apply 'write-line (list "Gefunden in folgendem Layout:" lch21))
                    (vl-catch-all-apply 'write-line (list (strcat "Gefunden in folgenden " (itoa lch18) " Layouts:") lch21))
                  )
                  (while lch12
                    (vl-catch-all-apply 'write-line (list (car lch12) lch21))
                    (setq lch12 (cdr lch12))
                  )
                )
                (vl-catch-all-apply 'write-line (list "Gesuchter Layer wurde in keinem Layout gefunden." lch21))
              )
            (vl-catch-all-apply 'write-line (list "" lch21))
              (if (> (setq lch19 (length lch13)) 0)
                (progn
                  (if (= lch19 1)
                    (vl-catch-all-apply 'write-line (list "Gefunden in folgendem Block:" lch21))
                    (vl-catch-all-apply 'write-line (list (strcat "Gefunden in folgenden " (itoa lch19) " Blöcken:") lch21))
                  )
                  (while lch13
                    (vl-catch-all-apply 'write-line (list (car lch13) lch21))
                    (setq lch13 (cdr lch13))
                  )
                )
                (vl-catch-all-apply 'write-line (list "Gesuchter Layer wurde in keinem Block gefunden." lch21))
              )
            (setq lch21 (close lch21))
            (alert (strcat "Protokolldatei \042" (lhc05 lch20 39) "\42 wurde geschrieben."))
            (prompt "\n*** ")
            (prompt (strcat "\nProtokolldatei \042" lch20 "\42 wurde geschrieben. "))
            (prompt "\n*** \n")
          )
        )
    )
    (defun lhc04 (lch04 / lch22 lch23 lch24 lch25 lch26 lch27 lch28)
      (setq lch22 (getvar "CDATE"))
      (setq lch23 (rtos lch22 2 0))
      (setq lch24 (substr lch23 1 4))
      (setq lch25 (substr lch23 5 2))
      (setq lch26 (substr lch23 7 2))
      (setq lch27 (list "Januar" "Februar" "März" "April" "Mai" "Juni" "Juli" "August" "September" "Oktober" "November" "Dezember"))
        (if (= lch04 0)
          (setq lch28 (strcat lch26 "." lch25 "." lch24))
          (setq lch28 (strcat lch26 ". " (nth (1- (atoi lch25)) lch27) " " lch24))
        )
      lch28
    )
    (defun lhc05 (lch05 lch06 / lch32 lch29 lch30 lch31)
      (setq lch29 (strlen lch05))
        (if (> lch29 lch06)
          (progn
            (setq lch30 (substr lch05 1 (/ (- lch06 3) 2)))
            (setq lch31 (substr lch05 (- lch29 (1- (/ (- lch06 3) 2)))))
            (setq lch32 (strcat lch30 "\056\056\056" lch31))
          )
        )
        (if lch32
          lch32
          lch05
        )
    )
    (defun lhc06 (lch05 lch07 / lch29 lch33 lch34 lch35)
      (setq lch29 (strlen lch05))
      (setq lch33 1)
        (while (<= lch33 lch29)
          (setq lch34 (substr lch05 lch33 1))
            (if (/= lch34 lch07)
              (progn
                (setq lch35 nil)
                (setq lch33 (1+ lch33))
              )
            )
            (if (= lch34 lch07)
              (progn
                (setq lch35 lch33)
                (setq lch33 (1+ lch29))
              )
            )
        )
      lch35
    )
    (defun lhc07 (lch05 lch02 / lch29 lch34 lch36 lch37)
      (setq lch29 (strlen lch05))
      (setq lch34 (substr lch05 1 1))
      (setq lch36 0)
        (while
          (and
            (/= (member lch34 lch02) nil)
            (/= lch36 lch29)
          )
            (setq lch05 (substr lch05 2))
            (setq lch34 (substr lch05 1 1))
            (setq lch36 (+ lch36 1))
        )
        (if (/= lch36 lch29)
          (progn
            (setq lch29 (strlen lch05))
            (setq lch37 (substr lch05 lch29 1))
            (setq lch36 lch29)
              (while
                (and
                  (/= (member lch37 lch02) nil)
                  (/= lch36 0)
                )
                  (setq lch05 (substr lch05 1 lch36))
                  (setq lch37 (substr lch05 lch36 1))
                  (setq lch36 (- lch36 1))
              )
          )
        )
      lch05
    )
    (defun lhc08 (lch08 lch09 / lch38 lch35 lch39 lch40)
      (if
        (and
          (= (type lch08) 'STR)
          (= (type lch09) 'STR)
        )
          (progn
            (setq lch38 (lhc07 lch08 (list lch09)))
            (setq lch35 (lhc06 lch38 lch09))
              (if lch35
                (progn
                  (setq lch39 (substr lch38 1 (1- lch35)))
                  (setq lch38 (lhc07 (substr lch38 (1+ (strlen lch39))) (list lch09)))
                  (setq lch40 (cons lch39 lch40))
                )
              )
            (setq lch35 (lhc06 lch38 lch09))
              (while lch35
                (setq lch39 (substr lch38 1 (1- lch35)))
                (setq lch38 (lhc07 (substr lch38 (1+ (strlen lch39))) (list lch09)))
                (setq lch40 (cons lch39 lch40))
                (setq lch35 (lhc06 lch38 lch09))
              )
              (if (> (strlen lch38) 0)
                (setq lch40 (cons lch38 lch40))
              )
          )
      )
      (if lch40
        (reverse lch40)
        nil
      )
    )
    (defun lhc09 ( / lch41)
      (setq lch41 (strcase (getvar "PRODUCT")))
        (if
          (and
            (= lch41 "AUTOCAD")
            (getvar "HPDRAWORDER")
          )
            (setq lch40 T)
            (setq lch40 nil)
        )
        (if (not lch40)
          (alert "\042acm-layercheck\042 kann nur unter AutoCAD ab Version 2005 verwendet werden.")
        )
      lch40
    )
    (defun lhc10 (lch10 / lch43 lch44 lch40)
        (if (not (vl-position uocn48a_bnwi33-ahw (list "0" "1")))
          (setq uocn48a_bnwi33-ahw "0")
        )
        (if (setq lch43 (lhc11))
          (progn
            (setq lch44 (load_dialog lch43))
              (if (not (new_dialog "acm524ll" lch44))
                (exit)
              )
            (vl-catch-all-apply 'vl-file-delete (list lch43))
            (start_list "lb_01")
            (mapcar 'add_list lch10)
            (end_list)
            (set_tile "tg_01" uocn48a_bnwi33-ahw)
              (if (= (get_tile "lb_01") "")
                (mode_tile "b_01" 1)
              )
              (action_tile "lb_01" "(if (> (length (lhc08 $value \" \")) 0)
                (mode_tile \"b_01\" 0))"
              )
              (action_tile "b_01" "(setq lch40 (list (setq uocn48a_bnwi33-ahw (get_tile \"tg_01\"))(nth (atoi (get_tile \"lb_01\")) lch10)))
                (done_dialog)"
              )
            (action_tile "b_02" "(setq lch40 nil) (done_dialog)")
            (start_dialog)
            (unload_dialog lch44)
          )
        )
      lch40
    )
    (defun lhc11 ( / lch45 lch21 lch46)
      (if
        (and
          (setq lch45 (vl-filename-mktemp "acm.dcl"))
          (setq lch21 (open lch45 "w"))
        )
          (progn
            (setq lch46
              (list
                "acm524ll"
                ":dialog{label=\042Layer wählen\042;"
                ":spacer{height=0.4;}"
                ":list_box{key=\042lb_01\042;width=25;height=9;allow_accept=true;}"
                ":spacer{height=0.3;}"
                ":toggle{key=\042tg_01\042;label=\042Protokolldatei &schreiben\042;}"
                ":spacer{height=0.5;}"
                ":row{"
                ":spacer{width=9;}"
                ":column{width=0;"
                ":button{key=\042b_01\042;label=\042OK\042;is_default=true;}"
                ":button{key=\042b_02\042;label=\042Abbrechen\042;is_cancel=true;}}"
                ":spacer{width=9;}}}"
              )
            )
              (while lch46
                (write-line (car lch46) lch21)
                (setq lch46 (cdr lch46))
              )
            (setq lch21 (close lch21))
            lch45
          )
          nil
      )
    )
    (defun lhc12 ( / lch47 lch34 lch48 lch18)
      (setq lch47 (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object))))
        (vlax-for lch34 lch47
          (setq lch48 (vlax-get lch34 'Name))
            (if
              (and
                (/= (vla-get-Lock lch34) :vlax-true)
                (not (vl-string-search "|" lch48))
                (/= (strcase lch48) "DEFPOINTS")
                (/= lch48 "0")
              )
                (setq lch18 (cons lch48 lch18))
            )
        )
        (if lch18
          (acad_strlsort lch18)
          nil
        )
    )
    (defun lhc13 (lch11 lch03 / lch48 lch49 lch50 lch51 lch62)
      (setq lch48 (strcase lch03))
      (setq lch49 0)
      (setq lch50 (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))))
        (if (/= (type (setq lch51 (vl-catch-all-apply 'vla-Item (list lch50 lch11)))) 'VL-CATCH-ALL-APPLY-ERROR)
          (progn
            (vlax-for lch62 lch51
              (if (= (strcase (vla-get-Layer lch62)) lch48)
                (setq lch49 (1+ lch49))
              )
            )
          )
        )
      lch49
    )
    (defun lhc14 ( / lch50 lch62 lch52)
      (setq lch50 (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))))
        (vlax-for lch62 lch50
          (setq lch52 (cons (vlax-get lch62 'Name) lch52))
        )
      lch52
    )
    (defun lhc15 (lch03 / lch50 lch53 lch54 lch55 lch12 lch13)
      (setq lch50 (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))))
      (setq lch53 (lhc14))
        (while lch53
          (setq lch54 (car lch53))
            (if (> (lhc13 lch54 lch03) 0)
              (progn
                (if (= (vla-get-IsLayout (setq lch55 (vla-Item lch50 lch54))) :vlax-true)
                  (setq lch12 (cons (vlax-get (vlax-get lch55 'Layout) 'Name) lch12))
                  (setq lch13 (cons lch54 lch13))
                )
              )
            )
          (setq lch53 (cdr lch53))
        )
      (list lch12 lch13)
    )
    (defun lhc16 ( / lch56 lch57 lch58 lch59 lch60)
      (sssetfirst nil nil)
      (princ)
        (if (setq lch56 (lhc12))
          (progn
            (if (setq lch57 (lhc10 lch56))
              (progn
                (setq lch58 (cadr lch57))
                (setq lch59 (car lch57))
                (setq lch60 (lhc15 lch58))
                (lhc02 lch60 lch58)
                  (if (= lch59 "1")
                    (lhc03 lch60 lch58)
                  )
              )
            )
          )
          (alert "Keine bereinigbaren Layer vorhanden.")
        )
    )
  (if (lhc09)
    (progn
      (vl-load-com)
      (sssetfirst nil nil)
      (setq lch16 (vla-get-ActiveDocument (vlax-get-acad-object)))
      (setq lch61 *error*)
      (setq *error* lhc01)
      (vla-EndUndoMark lch16)
      (vla-StartUndoMark lch16)
      (lhc16)
        (if lch61
          (setq *error* lch61)
          (setq *error* nil)
        )
      (vla-EndUndoMark lch16)
    )
  )
  (princ)
)
(terpri)
(princ (strcat "\nAutoLISP-Tool ACM-LAYERCHECK (Copyright © " (substr (rtos (getvar "CDATE")) 1 4) " Gerhard Rampf) geladen. "))
(princ "\nRufen Sie den Befehl mit ACM-LAYERCHECK auf.")
