;;;   Programm:      ACM-BKSLOESCHEN.LSP
;;;   Befehlsaufruf: ACM-BKSLOESCHEN
;;;   Funktion:      Benannte Benutzerkoordinatensysteme löschen per Auswahlliste oder
;;;                  Option "Alle".
;;;   Autor:         Gerhard Rampf
;;;                  Kundenspezifische Anpassungen für AutoCAD und ZWCAD
;;;                  Liebigstr. 3 A
;;;                  86399 Bobingen
;;;                  E-Mail: rampf@geracad.de
;;;   Datum:         16.07.2025
;;;   Plattform:     Alle AutoCAD-Versionen ab Version 2005
(defun c:acm-bksloeschen ( / bkl24 bkl67 blk01 blk02 blk03 blk04 blk05 blk06 blk07 blk08 blk09 blk10 blk11 blk12 blk13 blk14 blk15)
(defun blk01 (bkl01 bkl02 / bkl15 bkl16 bkl17 bkl18 bkl20 bkl19)
(if (= bkl02 "")
(progn
(alert "Keine Eingabe für \042Suchen nach\042.")
(mode_tile "eb_01" 2))
(progn
(setq bkl15 (mapcar 'strcase bkl01))
(setq bkl16 (strcase bkl02))
(setq bkl17 "")
(setq bkl18 -1)
(setq bkl19 0)
(repeat (length bkl15)
(setq bkl18 (1+ bkl18))
(if (wcmatch (nth bkl18 bkl15) bkl16)
(progn
(setq bkl17 (strcat bkl17 (itoa bkl18) " "))
(setq bkl19 (1+ bkl19)))))
(if
(and
(<= bkl19 250)
(/= (setq bkl20 (vl-string-trim " " bkl17)) ""))
(progn
(set_tile "lb_01" "")
(set_tile "lb_01" bkl20)
(mode_tile "b_01" 0))
(progn
(set_tile "lb_01" "0")
(set_tile "lb_01" "")
(if (> bkl19 250)
(alert "Ungültige Auswahl. Mehr als 250 entsprechende BKS gefunden.")
(alert "Es wurden keine entsprechenden BKS gefunden."))
(mode_tile "eb_01" 2)
(mode_tile "b_01" 1))))))
(defun blk02 ( / bkl21)
(setq bkl21 (strcase (getvar "PRODUCT")))
(if
(and
(= bkl21 "AUTOCAD")
(getvar "HPDRAWORDER"))
(setq bkl22 T)
(setq bkl22 nil))
(if (not bkl22)
(alert "\042acm-bksloeschen\042 kann nur unter AutoCAD ab Version 2005 verwendet werden."))
bkl22)
(defun blk03 (bkl03 / )
(if bkl66 (vl-catch-all-apply 'setvar (list "CMDECHO" bkl66)))
(if bkl67 (setq *error* bkl67))
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
(princ))
(defun blk04 ( / bkl23 bkl24 bkl25 bkl999 bkl26 bkl27)
(setq bkl23 (vlax-get-acad-object))
(setq bkl24 (vla-get-ActiveDocument bkl23))
(setq bkl25 (vlax-get bkl24 'UserCoordinateSystems))
(vlax-for bkl999 bkl25
(if (not (vl-string-search "|" (setq bkl26 (vlax-get bkl999 'Name))))
(setq bkl27 (cons bkl26 bkl27))))
(if bkl27
(acad_strlsort bkl27)))
(defun blk05 ( / bkl28 bkl29 bkl30 bkl31)
(setq bkl28 (cdr (assoc 8 hhxk48a_h&&-sfwure_1)))
(setq bkl29 (blk06 bkl28 ","))
(while bkl29
(setq bkl30 (car bkl29))
(setq bkl31 (cons bkl30 bkl31))
(setq bkl29 (cdr bkl29)))
(if bkl31
(progn
(setq bkl31 (acad_strlsort bkl31))
(prompt "\n ")
(prompt (strcat "\n" (itoa (length bkl31)) " benannte(s) BKS wurde(n) gelöscht: "))
(while bkl31
(prompt (strcat "\n" (car bkl31) " "))
(setq bkl31 (cdr bkl31)))
(prompt "\n "))))
(defun blk06 (bkl04 bkl05 / bkl32 bkl33)
(if
(and
(= (type bkl04) 'STR)
(= (type bkl05) 'STR))
(progn
(setq bkl04 (vl-string-trim bkl05 bkl04))
(setq bkl04 (vl-string-trim " " bkl04))
(while (setq bkl32 (vl-string-search bkl05 bkl04))
(setq bkl33 (append bkl33 (list (substr bkl04 1 bkl32))))
(setq bkl04 (vl-string-left-trim bkl05 (substr bkl04 (1+ bkl32)))))
(setq bkl33 (append bkl33 (list bkl04)))))
bkl33)
(defun blk07 (bkl06 bkl07 / bkl34 bkl35 bkl36 bkl32)
(setq bkl34 (strlen bkl06))
(setq bkl35 1)
(while (<= bkl35 bkl34)
(setq bkl36 (substr bkl06 bkl35 1))
(if (/= bkl36 bkl07)
(progn
(setq bkl32 nil)
(setq bkl35 (1+ bkl35))))
(if (= bkl36 bkl07)
(progn
(setq bkl32 bkl35)
(setq bkl35 (1+ bkl34)))))
bkl32)
(defun blk08 (bkl06 bkl08 / bkl34 bkl36 bkl18 bkl37)
(setq bkl34 (strlen bkl06))
(setq bkl36 (substr bkl06 1 1))
(setq bkl18 0)
(while
(and
(/= (member bkl36 bkl08) nil)
(/= bkl18 bkl34))
(setq bkl06 (substr bkl06 2))
(setq bkl36 (substr bkl06 1 1))
(setq bkl18 (+ bkl18 1)))
(if (/= bkl18 bkl34)
(progn
(setq bkl34 (strlen bkl06))
(setq bkl37 (substr bkl06 bkl34 1))
(setq bkl18 bkl34)
(while
(and
(/= (member bkl37 bkl08) nil)
(/= bkl18 0))
(setq bkl06 (substr bkl06 1 bkl18))
(setq bkl37 (substr bkl06 bkl18 1))
(setq bkl18 (- bkl18 1)))))
bkl06)
(defun blk09 (bkl09 bkl10 / bkl38 bkl32 bkl39 bkl22)
(if
(and
(= (type bkl09) 'STR)
(= (type bkl10) 'STR))
(progn
(setq bkl38 (blk08 bkl09 (list bkl10)))
(setq bkl32 (blk07 bkl38 bkl10))
(if bkl32
(progn
(setq bkl39 (substr bkl38 1 (1- bkl32)))
(setq bkl38 (blk08 (substr bkl38 (1+ (strlen bkl39))) (list bkl10)))
(setq bkl22 (cons bkl39 bkl22))))
(setq bkl32 (blk07 bkl38 bkl10))
(while bkl32
(setq bkl39 (substr bkl38 1 (1- bkl32)))
(setq bkl38 (blk08 (substr bkl38 (1+ (strlen bkl39))) (list bkl10)))
(setq bkl22 (cons bkl39 bkl22))
(setq bkl32 (blk07 bkl38 bkl10)))
(if (> (strlen bkl38) 0)
(setq bkl22 (cons bkl38 bkl22)))))
(if bkl22
(reverse bkl22)
nil))
(defun blk10 (bkl11 / bkl40 bkl41 bkl36)
(setq bkl40 bkl11)
(setq bkl41 "")
(while bkl40
(setq bkl36 (car bkl40))
(setq bkl41 (strcat bkl41 bkl36 ","))
(setq bkl40 (cdr bkl40)))
(setq bkl41 (blk11 bkl41 1))
(if (/= bkl41 "")
(list (cons 8 bkl41))
nil))
(defun blk11 (bkl12 bkl13 / bkl34 bkl42)
(setq bkl34 (strlen bkl12))
(if (> bkl13 bkl34)
(setq bkl13 bkl34))
(setq bkl42 (- bkl34 bkl13))
(setq bkl12 (substr bkl12 1 bkl42)))
(defun blk12 (bkl14 / bkl43 bkl44 bkl28 bkl45 bkl46 bkl32 bkl47 bkl48 bkl41 bkl49 bkl50 bkl51 bkl52 bkl53 bkl22)
(if (setq bkl43 (blk13))
(progn
(setq bkl44 (load_dialog bkl43))
(if (not (new_dialog "acm624lo" bkl44))
(exit))
(vl-catch-all-apply 'vl-file-delete (list bkl43))
(start_list "lb_01")
(mapcar 'add_list bkl14)
(end_list)
(if
(and
(= (type hhxk48a_h&&-sfwure_1) 'LIST)
(setq bkl28 (cdr (assoc 8 hhxk48a_h&&-sfwure_1))))
(progn
(setq bkl45 (blk06 bkl28 ","))
(setq bkl45 (mapcar 'strcase bkl45))
(setq bkl46 (mapcar 'strcase bkl14))
(while bkl45
(if (setq bkl32 (vl-position (car bkl45) bkl46))
(setq bkl47 (cons bkl32 bkl47)))
(setq bkl45 (cdr bkl45)))
(if bkl47
(progn
(setq bkl48 (vl-sort bkl47 '<))
(setq bkl41 "")
(while bkl48
(setq bkl41 (strcat bkl41 (itoa (car bkl48)) " "))
(setq bkl48 (cdr bkl48)))
(setq bkl49 (blk11 bkl41 1)))
(setq bkl49 nil)))
(setq bkl49 nil))
(if bkl49
(set_tile "lb_01" bkl49))
(if (= (get_tile "lb_01") "")
(mode_tile "b_01" 1))
(set_tile "t_01" (strcat (itoa (length (blk09 (get_tile "lb_01") " "))) " BKS gewählt"))
(action_tile "lb_01" "(if (> (length (blk09 $value \" \")) 250)
(progn
(alert \"Ungültige Auswahl. Bitte maximal 250 Einträge wählen.\")
(set_tile $key \"0\")
(set_tile $key \"\")
(mode_tile \"b_01\" 1))
(progn
(if (= (get_tile \"lb_01\") \"\")
(mode_tile \"b_01\" 1)
(mode_tile \"b_01\" 0))))
(set_tile \"t_01\" (strcat (itoa (length (blk09 (get_tile \"lb_01\") \" \"))) \" BKS gewählt\"))")
(action_tile "b_00" "(set_tile \"eb_01\" (setq bkl50 (vl-string-trim \" \" (get_tile \"eb_01\"))))
(blk01 bkl14 bkl50)
(set_tile \"t_01\" (strcat (itoa (length (blk09 (get_tile \"lb_01\") \" \"))) \" BKS gewählt\"))")
(action_tile "eb_01" "(if (= $reason 1)
(progn
(set_tile $key (setq bkl51 (vl-string-trim \" \" $value)))
(blk01 bkl14 bkl51)
(set_tile \"t_01\" (strcat (itoa (length (blk09 (get_tile \"lb_01\") \" \"))) \" BKS gewählt\")))
)")
(action_tile "b_01" "(setq bkl52 (blk09 (setq bkl53 (get_tile \"lb_01\")) \" \"))
(setq bkl52 (mapcar 'atoi bkl52))
(while bkl52
(setq bkl22 (cons (nth (car bkl52) bkl14) bkl22))
(setq bkl52 (cdr bkl52)))
(setq bkl22 (list 1 (setq hhxk48a_h&&-sfwure_1 (blk10 (reverse bkl22)))))
(done_dialog)")
(action_tile "b_02" "(setq bkl22 nil) (done_dialog)")
(start_dialog)
(unload_dialog bkl44)))
bkl22)
(defun blk13 ( / bkl55 bkl56 bkl57)
(if
(and
(setq bkl55 (vl-filename-mktemp "acm.dcl"))
(setq bkl56 (open bkl55 "w")))
(progn
(setq bkl57
(list
"acm624lo"
":dialog{label=\042BKS wählen\042;"
":spacer{height=0.4;}"
":list_box{key=\042lb_01\042;width=35;height=15;multiple_select=true;}"
":text{key=\042t_01\042;}"
":spacer{height=0;}"
":row{"
":button{key=\042b_00\042;label=\042&Suchen nach:\042;width=0;fixed_width=true;}"
":edit_box{key=\042eb_01\042;width=20;}}"
":spacer{height=0.4;}"
":row{"
":spacer{width=5;}"
":column{width=20;"
":button{key=\042b_01\042;label=\042OK\042;is_default=true;}"
":button{key=\042b_02\042;label=\042Abbrechen\042;is_cancel=true;}}"
":spacer{width=5;}}}"))
(while bkl57
(write-line (car bkl57) bkl56)
(setq bkl57 (cdr bkl57)))
(setq bkl56 (close bkl56))
bkl55)
nil))
(defun blk14 ( / bkl59 bkl60 bkl61)
(if (not (vl-position hhxk48a_h&&-sfwure_2 (list 2 3)))
(setq hhxk48a_h&&-sfwure_2 2))
(if (= (type hhxk48a_h&&-sfwure_1) 'LIST)
(progn
(setq bkl59 "auSwahlliste Alle")
(if (= hhxk48a_h&&-sfwure_2 2)
(setq bkl60 "\nZu löschende BKS wählen durch [auSwahlliste/Alle] <auSwahlliste>: "))
(if (= hhxk48a_h&&-sfwure_2 3)
(setq bkl60 "\nZu löschende BKS wählen durch [auSwahlliste/Alle] <Alle>: ")))
(progn
(if (not (vl-position hhxk48a_h&&-sfwure_2 (list 2 3)))
(setq hhxk48a_h&&-sfwure_2 2))
(setq bkl59 "auSwahlliste Alle")
(if (= hhxk48a_h&&-sfwure_2 2)
(setq bkl60 "\nZu löschende BKS wählen durch [auSwahlliste/Alle] <auSwahlliste>: "))
(if (= hhxk48a_h&&-sfwure_2 3)
(setq bkl60 "\nZu löschende BKS wählen durch [auSwahlliste/Alle] <Alle>: "))))
(initget bkl59)
(if (setq bkl61 (getkword bkl60))
(setq hhxk48a_h&&-sfwure_2 (nth (vl-position bkl61 (list "auSwahlliste" "Alle")) (list 2 3))))
hhxk48a_h&&-sfwure_2)
(defun blk15 ( / bkl66 bkl62 bkl63 bkl64 bkl65 bkl29)
(if (setq bkl62 (blk04))
(progn
(setq bkl63 (blk14))
(if (= bkl63 2)
(setq bkl64 (blk12 bkl62)))
(if (vl-position bkl63 (list 2))
(progn
(if bkl64
(progn
(setq hhxk48a_h&&-sfwure_1 (cadr bkl64))
(blk05)
(setq bkl65 (cdr (assoc 8 hhxk48a_h&&-sfwure_1)))
(setq bkl29 (blk06 bkl65 ","))
(setq bkl66 (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(while bkl29
(vl-cmdf "._ucs" "_delete" (car bkl29))
(setq bkl29 (cdr bkl29)))
(setvar "CMDECHO" bkl66))))
(progn
(if (= bkl63 3)
(progn
(setq bkl66 (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(vl-cmdf "._ucs" "_delete" "*")
(setvar "CMDECHO" bkl66)
(prompt "\nAlle benannten BKS wurden gelöscht. "))))))
(alert "Aktuell sind keine benannten BKS vorhanden.")))
(if (blk02)
(progn
(vl-load-com)
(setq bkl24 (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq bkl67 *error*)
(setq *error* blk03)
(vla-EndUndoMark bkl24)
(vla-StartUndoMark bkl24)
(blk15)
(if bkl67
(setq *error* bkl67)
(setq *error* nil))
(vla-EndUndoMark bkl24)))
(princ))
(terpri)
(princ (strcat "\nAutoLISP-Tool ACM-BKSLOESCHEN (Copyright © " (substr (rtos (getvar "CDATE")) 1 4) " Gerhard Rampf) geladen. "))
(princ "\nRufen Sie den Befehl mit ACM-BKSLOESCHEN auf.")
