;;; - ------------------------------------------------------------------------------ - ;
;;; -                 T O O L - K_WB                                                 - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Beschreibung :  wblock mit Extras                                              - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Befehle      :  k_wb                                                           - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - letzte Änderung am : 09.09.2023                                                - ;
;;; -              durch : Andreas Kraus                                             - ;
;;; - ------------------------------------------------------------------------------ - ;

(DEFUN COMPARE (E0 E1 /)
  (COND	((> (CAR E0) (CAR E1)) 1)
	((< (CAR E0) (CAR E1)) -1)
	((QUOTE T) 0)
  )
)
(DEFUN K_->ENT_NAME (NAME)
  (COND	((= (TYPE NAME) (QUOTE ENAME)) NAME)
	((= (TYPE NAME) (QUOTE VLA-OBJECT))
	 (vlax-vla-object->ename NAME)
	)
	((= (TYPE NAME) (QUOTE STR)) (HANDENT NAME))
	((AND (= (TYPE NAME) (QUOTE LIST)) (ASSOC -1 NAME))
	 (CDR (ASSOC -1 NAME))
	)
	((AND (= (TYPE NAME) (QUOTE LIST)) (ASSOC 5 NAME))
	 (HANDENT (CDR (ASSOC 5 NAME)))
	)
  )
)
(DEFUN K_->OBJ_NAME (NAME)
  (COND	((= (TYPE NAME) (QUOTE ENAME))
	 (vlax-ename->vla-object NAME)
	)
	((= (TYPE NAME) (QUOTE VLA-OBJECT)) NAME)
	((= (TYPE NAME) (QUOTE STR))
	 (vlax-ename->vla-object (HANDENT NAME))
	)
	((AND (= (TYPE NAME) (QUOTE LIST)) (ASSOC -1 NAME))
	 (vlax-ename->vla-object (CDR (ASSOC -1 NAME)))
	)
	((AND (= (TYPE NAME) (QUOTE LIST)) (ASSOC 5 NAME))
	 (vlax-ename->vla-object (HANDENT (CDR (ASSOC 5 NAME))))
	)
  )
)
(DEFUN K_AC-DOC	nil
  (vla-get-ActiveDocument (vlax-get-acad-object))
)
(DEFUN K_COLLECTION->LIST (COLLECTION / LISTE)
  (COND	((MEMBER "VLA-COLLECTION->LIST" (ATOMS-FAMILY 1))
	 (SETQ LISTE (VLA-COLLECTION->LIST COLLECTION))
	)
	((MEMBER "VLAX-FOR" (ATOMS-FAMILY 1))
	 (SETQ LISTE (LIST))
	 (VLAX-FOR DUMMY COLLECTION (SETQ LISTE (CONS DUMMY LISTE)))
	 (REVERSE LISTE)
	)
  )
  LISTE
)
(DEFUN K_ENTLIST->SATZ (ENT_LIST / N SATZ ENT_NAME)
  (IF (LISTP ENT_LIST)
    (PROGN (SETQ SATZ (SSADD))
	   (MAPCAR (QUOTE
		     (LAMBDA (ENT_NAME)
		       (COND ((AND (= (TYPE ENT_NAME) (QUOTE VLA-OBJECT))
				   (K_->ENT_NAME ENT_NAME)
			      )
			      (SETQ SATZ (SSADD (vlax-vla-object->ename ENT_NAME) SATZ))
			     )
			     ((AND (= (TYPE ENT_NAME) (QUOTE ENAME))
				   (K_->OBJ_NAME ENT_NAME)
			      )
			      (SETQ SATZ (SSADD ENT_NAME SATZ))
			     )
			     ((= (TYPE ENT_NAME) (QUOTE STR))
			      (IF (HANDENT ENT_NAME)
				(SETQ SATZ (SSADD (HANDENT ENT_NAME) SATZ))
			      )
			     )
		       )
		     )
		   )
		   ENT_LIST
	   )
    )
  )
  SATZ
)
(DEFUN K_GET_MERKLISTE (NAME / WERT)
  (IF (ASSOC NAME K_MERKLISTE)
    (SETQ WERT (NTH 1 (ASSOC NAME K_MERKLISTE)))
  )
  WERT
)
(DEFUN K_MEM_LAYSTAT (/ LAYSTATLIST LAY)
  (SETQ	LAYSTATLIST
	 (MAPCAR (QUOTE	(LAMBDA	(LAY)
			  (LIST	(vla-get-Name LAY)
				(vla-get-LayerOn LAY)
				(vla-get-Freeze LAY)
				(vla-get-Lock LAY)
			  )
			)
		 )
		 (K_COLLECTION->LIST (vla-get-Layers (K_AC-DOC)))
	 )
  )
  (K_PUT_MERKLISTE
    "k_mem_laystat"
    (VL-REMOVE (QUOTE nil)
	       (CONS LAYSTATLIST (K_GET_MERKLISTE "k_mem_laystat"))
    )
  )
  (PRINC)
)
(DEFUN K_PURGE_LIST (LISTE / DUMMY_LIST)
  (WHILE LISTE
    (SETQ DUMMY_LIST (CONS (CAR LISTE) DUMMY_LIST)
	  LISTE	     (VL-REMOVE (CAR LISTE) LISTE)
    )
  )
  (REVERSE DUMMY_LIST)
)
(DEFUN K_PUT_MERKLISTE (NAME WERT)
  (IF (ASSOC NAME K_MERKLISTE)
    (SETQ K_MERKLISTE
	   (SUBST (LIST NAME WERT)
		  (ASSOC NAME K_MERKLISTE)
		  K_MERKLISTE
	   )
    )
    (SETQ K_MERKLISTE (CONS (LIST NAME WERT) K_MERKLISTE))
  )
  (PRINC)
)
(DEFUN K_RST_LAYSTAT (/ OBJ_NAME DAT)
  (SETVAR "cmdecho" 0)
  (FOREACH DAT (CAR (K_GET_MERKLISTE "k_mem_laystat"))
    (IF	(AND (TBLSEARCH "LAYER" (NTH 0 DAT))
	     (SETQ OBJ_NAME (vla-Item (vla-get-Layers (K_AC-DOC)) (NTH 0 DAT)))
	)
      (PROGN (vla-put-LayerOn OBJ_NAME (NTH 1 DAT))
	     (IF (/= (CAR DAT) (GETVAR "clayer"))
	       (vla-put-Freeze OBJ_NAME (NTH 2 DAT))
	     )
	     (vla-put-Lock OBJ_NAME (NTH 3 DAT))
      )
    )
  )
  (IF (CDR (K_GET_MERKLISTE "k_mem_laystat"))
    (K_PUT_MERKLISTE
      "k_mem_laystat"
      (CDR (K_GET_MERKLISTE "k_mem_laystat"))
    )
  )
  (PRINC)
)
(DEFUN K_SATZ->ENTLIST (SATZ)
  (IF (= (TYPE SATZ) (QUOTE PICKSET))
    (VL-REMOVE-IF-NOT
      (QUOTE (LAMBDA (DUMMY) (= (TYPE DUMMY) (QUOTE ENAME))))
      (MAPCAR (QUOTE CADR) (SSNAMEX SATZ))
    )
  )
)
(DEFUN K_SATZ->OBJLIST (SATZ)
  (MAPCAR (QUOTE vlax-ename->vla-object)
	  (K_SATZ->ENTLIST SATZ)
  )
)
(DEFUN K_SATZ->REFLIST (SATZ / N REF_LIST)
  (IF (= (TYPE SATZ) (QUOTE PICKSET))
    (MAPCAR (QUOTE (LAMBDA (OBJ) (vla-get-Handle OBJ)))
	    (K_SATZ->OBJLIST SATZ)
    )
  )
)
(DEFUN L-2NDINHIBITION (L0 L1 / CMP L2)
  (SETQ L0 (VL-SORT (MAKE-SORTABLE L0) (QUOTE _<)))
  (SETQ L1 (VL-SORT (MAKE-SORTABLE L1) (QUOTE _<)))
  (WHILE (AND L0 L1)
    (SETQ CMP (COMPARE (CAR L0) (CAR L1)))
    (COND ((= CMP -1)
	   (SETQ L2 (CONS (CDAR L0) L2)
		 L0 (CDR L0)
	   )
	  )
	  ((= CMP 1) (SETQ L1 (CDR L1)))
	  ((QUOTE T)
	   (SETQ L0 (CDR L0)
		 L1 (CDR L1)
	   )
	  )
    )
  )
  (APPEND L2 (MAPCAR (QUOTE CDR) L0))
)
(DEFUN MAKE-SORTABLE (L /)
  (MAPCAR (QUOTE (LAMBDA (E /) (CONS (VL-PRIN1-TO-STRING E) E)))
	  L
  )
)
(DEFUN _< (E0 E1 /) (< (CAR E0) (CAR E1)))

(defun c:k_wb (/ DATEINAME DUMMY HANDLE K_WBLIST LAYER P REF SATZ)
;;; WBLOCK-Liste
  (initget
    "Auswahl Hinzufügen Entfernen Speichern Gesamtspeichern Rücksetzen Markieren"
  )
  (setq
    dummy
     (getkword
       "[Auswahl/Hinzufügen/Entfernen/Speichern/Gesamtspeichern/Rücksetzen/Markieren]"
     )
  )
  (if (null dummy)
    (setq dummy "Auswahl")
  )
  (setq	k_wblist (k_get_merkliste
		   (strcat "k_wblist-"
			   (vla-get-handle (vla-get-activelayout (k_ac-doc)))
		   )
		 )
  )
  (cond
    ((= dummy "Auswahl")
     (if (setq satz (ssget))
       (progn
	 (setq k_wblist (k_purge_list (k_satz->reflist satz)))
	 (k_put_merkliste
	   (strcat "k_wblist-"
		   (vla-get-handle (vla-get-activelayout (k_ac-doc)))
	   )
	   k_wblist
	 )
       )
     )
    )
    ((= dummy "Hinzufügen")
     (if (setq satz (ssget))
       (progn
	 (setq k_wblist	(k_purge_list
			  (append k_wblist (k_satz->reflist satz))
			)
	 )
	 (k_put_merkliste
	   (strcat "k_wblist-"
		   (vla-get-handle (vla-get-activelayout (k_ac-doc)))
	   )
	   k_wblist
	 )
       )
     )
    )
    ((= dummy "Entfernen")
     (if (setq satz (ssget))
       (progn
	 (mapcar '(lambda (ref)
		    (setq k_wblist (vl-remove ref k_wblist))
		  )
		 (k_satz->reflist satz)
	 )
	 (k_put_merkliste
	   (strcat "k_wblist-"
		   (vla-get-handle (vla-get-activelayout (k_ac-doc)))
	   )
	   k_wblist
	 )
       )
     )
    )
    ((= dummy "Speichern")
     (if (setq dateiname (getfiled "WBLOCK" (getvar "dwgprefix") "dwg" 3))
       (if (vl-file-rename dateiname dateiname)
	 (if (setq p (getpoint "Basispunkt"))
	   (progn
	     (k_mem_laystat)
	     (mapcar '(lambda (layer) (vla-put-lock layer 0))
		     (k_collection->list (vla-get-layers (k_ac-doc)))
	     )
	     (if (findfile dateiname)
	       (command	"_wblock"
			dateiname
			"j"
			""
			p
			(k_entlist->satz k_wblist)
			""
	       )
	       (command	"_wblock"
			dateiname
			""
			p
			(k_entlist->satz k_wblist)
			""
	       )
	     )
	     (command "_oops")
	     (k_rst_laystat)
	   )
	 )
	 (alert "Datei ist schreibgeschützt")
       )
     )
    )
    ((= dummy "Gesamtspeichern")
     (setvar "tilemode" 1)
     (if (setq dateiname (getfiled "WBLOCK" (getvar "dwgprefix") "dwg" 3))
       (if (vl-file-rename dateiname dateiname)
	 (progn
	   (vla-startundomark (k_ac-doc))
	   (k_mem_laystat)
	   (mapcar '(lambda (layer) (vla-put-lock layer 0))
		   (k_collection->list (vla-get-layers (k_ac-doc)))
	   )
	   (mapcar 'vla-delete
		   (l-2ndinhibition
		     (vl-remove-if
		       '(lambda	(obj)
			  (and (= (vla-get-ObjectName obj) "AcDbViewport")
			       (= (cdr (assoc 69 (entget (k_->ent_name obj)))) 1)
			  )
			)
		       (apply 'append
			      (mapcar 'k_collection->list
				      (k_collection->list (vla-get-blocks (k_ac-doc)))
			      )
		       )
		     )
		     (mapcar 'k_->obj_name
			     (apply 'append
				    (mapcar '(lambda (handle)
					       (k_get_merkliste (strcat "k_wblist-" handle))
					     )
					    (mapcar 'vla-get-handle
						    (k_collection->list (vla-get-layouts (k_ac-doc)))
					    )
				    )
			     )
		     )
		   )
	   )
	   (if (findfile dateiname)
	     (command "_wblock"
		      dateiname
		      "j"
		      "*"
	     )
	     (command "_wblock"
		      dateiname
		      "*"
	     )
	   )
	   (k_rst_laystat)
	   (vla-endundomark (k_ac-doc))
	   (command "_undo" "1")
	 )
	 (alert "Datei ist schreibgeschützt")
       )
     )
    )
    ((= dummy "Rücksetzen")
     (setq k_wblist (list))
     (k_put_merkliste
       (strcat "k_wblist-"
	       (vla-get-handle (vla-get-activelayout (k_ac-doc)))
       )
       k_wblist
     )
    )
    ((= dummy "Markieren")
     (command "_select"
	      (k_entlist->satz (mapcar 'handent k_wblist))
	      ""
     )
     (sssetfirst
       (k_entlist->satz (mapcar 'handent k_wblist))
       (k_entlist->satz (mapcar 'handent k_wblist))
     )
    )
  )
)
;;; - ------------------------------------------------------------------------------ - ;
(princ
  (strcat
    "\nk_wb:  wblock mit Extras"
    "\n===========  "
    "\n(C) Andreas Kraus 2023 (info@kraus-cad.de)"
    "\nBefehlszeilenaufruf : k_wb\n"
  )
)
;;; - ------------------------------------------------------------------------------ - ;
(princ)