;;; - ------------------------------------------------------------------------------ - ;
;;; -                 T O O L - K_BLKADD                                             - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Beschreibung :  Objekte zu Block hinzufügen                                    - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Befehle      :  k_blkadd                                                       - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - letzte Änderung am : 25.06.2024                                                - ;
;;; -              durch : Andreas Kraus                                             - ;
;;; - ------------------------------------------------------------------------------ - ;

(vl-load-com)
(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_3D->2D	(WERT / DUMMY)
  (IF (VL-EVERY	(QUOTE (LAMBDA (DUMMY) (= (TYPE DUMMY) (QUOTE LIST))))
		WERT
      )
    (MAPCAR (QUOTE (LAMBDA (DUMMY) (LIST (CAR DUMMY) (CADR DUMMY))))
	    WERT
    )
    (LIST (CAR WERT) (CADR WERT))
  )
)
(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_COPYOBJECTS (OBJ_LIST QUELLE ZIEL RET / NEW_LIST)
  (IF (NULL QUELLE)
    (SETQ QUELLE (K_AC-DOC))
  )
  (COND	((= (TYPE OBJ_LIST) (QUOTE ENAME))
	 (SETQ OBJ_LIST (LIST (vlax-ename->vla-object OBJ_LIST)))
	)
	((= (TYPE OBJ_LIST) (QUOTE VLA-OBJECT))
	 (SETQ OBJ_LIST (LIST OBJ_LIST))
	)
	((= (TYPE OBJ_LIST) (QUOTE LIST))
	 (SETQ OBJ_LIST (MAPCAR (QUOTE K_->OBJ_NAME) OBJ_LIST))
	)
	(T nil)
  )
  (SETQ	OBJ_LIST (VL-REMOVE (QUOTE nil)
			    (MAPCAR (QUOTE
				      (LAMBDA (OBJ)
					(COND ((= (TYPE OBJ) (QUOTE ENAME)) (vlax-ename->vla-object OBJ))
					      ((= (TYPE OBJ) (QUOTE VLA-OBJECT)) OBJ)
					      (T nil)
					)
				      )
				    )
				    OBJ_LIST
			    )
		 )
  )
  (SETQ	NEW_LIST (VL-CATCH-ALL-APPLY
		   (QUOTE vlax-invoke)
		   (LIST QUELLE (QUOTE COPYOBJECTS) OBJ_LIST ZIEL)
		 )
  )
  (IF RET
    NEW_LIST
    nil
  )
)
(DEFUN K_EXPLODE (OBJ_LIST / ENT_LIST DUMMY_LIST ENT FERTIG_LIST)
  (IF (NOT (LISTP OBJ_LIST))
    (SETQ OBJ_LIST (LIST OBJ_LIST))
  )
  (SETQ OBJ_LIST (MAPCAR (QUOTE K_->OBJ_NAME) OBJ_LIST))
  (FOREACH OBJ OBJ_LIST
    (IF	(vlax-method-applicable-p OBJ (QUOTE EXPLODE))
      (PROGN (SETQ ENT (ENTLAST))
	     (IF (NOT (SETQ DUMMY_LIST (K_VARIANT->VALUE (vla-Explode OBJ))))
	       (PROGN (WHILE (NOT (EQUAL ENT (ENTLAST)))
			(SETQ ENT_LIST (CONS (SETQ ENT (ENTNEXT ENT)) ENT_LIST))
		      )
		      (SETQ DUMMY_LIST
			     (MAPCAR (QUOTE K_->OBJ_NAME)
				     (VL-REMOVE (QUOTE nil) ENT_LIST)
			     )
		      )
	       )
	     )
	     (SETQ FERTIG_LIST (APPEND FERTIG_LIST DUMMY_LIST))
      )
      (SETQ FERTIG_LIST (APPEND FERTIG_LIST (LIST OBJ)))
    )
  )
)
(DEFUN K_FILTER	(OBJ_LIST FILTER_LIST)
  (IF (NOT (LISTP (CAR FILTER_LIST)))
    (SETQ FILTER_LIST (LIST FILTER_LIST))
  )
  (FOREACH FILTER FILTER_LIST
    (SETQ OBJ_LIST (VL-REMOVE-IF-NOT
		     (QUOTE
		       (LAMBDA (OBJ)
			 (IF (VL-CATCH-ALL-ERROR-P
			       (SETQ DUMMY (VL-CATCH-ALL-APPLY
					     (QUOTE EVAL)
					     (LIST
					       (LIST (READ (STRCAT "vla-get-" (VL-PRINC-TO-STRING (CAR FILTER))))
						     OBJ
					       )
					     )
					   )
			       )
			     )
			   nil
			   (EQUAL (K_VARIANT->VALUE
				    (EVAL
				      (LIST (READ (STRCAT "vla-get-" (VL-PRINC-TO-STRING (CAR FILTER))))
					    OBJ
				      )
				    )
				  )
				  (CADR FILTER)
			   )
			 )
		       )
		     )
		     OBJ_LIST
		   )
    )
  )
  OBJ_LIST
)
(DEFUN K_GET-DEF (OBJ_NAME FILE)
  (IF (NULL FILE)
    (SETQ FILE (K_AC-DOC))
  )
  (SETQ OBJ_NAME (K_->OBJ_NAME OBJ_NAME))
  (COND	((= (vla-get-ObjectName OBJ_NAME) "AcDbBlockReference")
	 (vla-Item (vla-get-Blocks FILE) (vla-get-Name OBJ_NAME))
	)
	((= (vla-get-ObjectName OBJ_NAME) "AcDbAttribute")
	 (CAR
	   (K_FILTER (K_COLLECTION->LIST
		       (vla-Item (vla-get-Blocks FILE)
				 (CDR
				   (ASSOC 2
					  (ENTGET (CDR (ASSOC 330 (ENTGET (K_->ENT_NAME OBJ_NAME)))))
				   )
				 )
		       )
		     )
		     (LIST "tagstring" (vla-get-TagString OBJ_NAME))
	   )
	 )
	)
	((= (vla-get-ObjectName OBJ_NAME) "AcDbMline")
	 (vla-Item (vla-Item (vla-get-Dictionaries FILE) "acad_mlinestyle")
		   (vla-get-StyleName OBJ_NAME)
	 )
	)
	(T nil)
  )
)
(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_NTH (LISTE N)
  (COND	((= (TYPE N) (QUOTE INT)) (NTH N LISTE))
	((= (TYPE N) (QUOTE LIST))
	 (MAPCAR (QUOTE (LAMBDA (N) (NTH N LISTE))) N)
	)
  )
)
(DEFUN K_OFANG (MODUS)
  (COND	((AND (= MODUS "aus") (= (LOGAND (GETVAR "osmode") 16384) 0))
	 (SETVAR "osmode" (+ (GETVAR "osmode") 16384))
	)
	((AND (= MODUS "ein")
	      (= (LOGAND (GETVAR "osmode") 16384) 16384)
	 )
	 (SETVAR "osmode" (- (GETVAR "osmode") 16384))
	)
	((= (TYPE MODUS) (QUOTE INT))
	 (IF (MINUSP MODUS)
	   (SETVAR "osmode"
		   (K_GET_MERKLISTE (STRCAT "osmode" (ITOA (ABS MODUS))))
	   )
	   (K_PUT_MERKLISTE
	     (STRCAT "osmode" (ITOA MODUS))
	     (GETVAR "osmode")
	   )
	 )
	)
	((= MODUS "mem")
	 (K_PUT_MERKLISTE "osmode" (GETVAR "osmode"))
	)
	((AND (= MODUS "restore") (K_GET_MERKLISTE "osmode"))
	 (SETVAR "osmode" (K_GET_MERKLISTE "osmode"))
	)
  )
)
(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_P_TWIST (P PX WX / PZ PXZ)
  (SETQ	PZ  (CADDR P)
	PXZ (CADDR PX)
  )
  (SETQ	P  (K_3D->2D P)
	PX (K_3D->2D PX)
  )
  (VL-REMOVE (QUOTE nil)
	     (APPEND (POLAR PX (+ (ANGLE PX P) WX) (DISTANCE PX P))
		     (LIST PZ)
	     )
  )
)
(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_TEMP-BLK (OBJ_LIST / BLK-NAME)
  (IF (SETQ OBJ_LIST (VL-REMOVE	(QUOTE nil)
				(COND ((= (TYPE OBJ_LIST) (QUOTE PICKSET))
				       (K_SATZ->OBJLIST OBJ_LIST)
				      )
				      ((= (TYPE OBJ_LIST) (QUOTE LIST))
				       (MAPCAR (QUOTE K_->OBJ_NAME) OBJ_LIST)
				      )
				      ((= (TYPE OBJ_LIST) (QUOTE ENAME))
				       (LIST (K_->OBJ_NAME OBJ_LIST))
				      )
				      ((= (TYPE OBJ_LIST) (QUOTE VLA-OBJECT)) (LIST OBJ_LIST))
				      (T nil)
				)
		     )
      )
    (PROGN (ENTMAKE (LIST (CONS 0 "BLOCK")
			  (CONS 70 3)
			  (CONS 2 "*U")
			  (LIST 10 0 0 0)
		    )
	   )
	   (SETQ BLK-NAME (ENTMAKE (LIST (CONS 0 "endblk"))))
	   (FOREACH ENT_NAME OBJ_LIST
	     (K_COPYOBJECTS
	       ENT_NAME
	       nil
	       (vla-Item (vla-get-Blocks (K_AC-DOC)) BLK-NAME)
	       nil
	     )
	   )
	   (K_->OBJ_NAME
	     (ENTMAKEX (LIST (QUOTE (0 . "INSERT"))
			     (QUOTE (100 . "AcDbEntity"))
			     (QUOTE (67 . 0))
			     (QUOTE (410 . "Model"))
			     (QUOTE (8 . "0"))
			     (QUOTE (100 . "AcDbBlockReference"))
			     (CONS 2 BLK-NAME)
			     (LIST 10 0 0 0)
			     (QUOTE (41 . 1.0))
			     (QUOTE (42 . 1.0))
			     (QUOTE (43 . 1.0))
			     (QUOTE (50 . 0.0))
			     (QUOTE (70 . 0))
			     (QUOTE (71 . 0))
			     (QUOTE (44 . 0.0))
			     (QUOTE (45 . 0.0))
			     (QUOTE (210 0.0 0.0 1.0))
		       )
	     )
	   )
    )
  )
)
(DEFUN K_VARIANT->VALUE	(VAR / VALUE)
  (IF (= (TYPE VAR) (QUOTE variant))
    (PROGN (SETQ VALUE (vlax-variant-value VAR))
	   (COND ((= (TYPE VALUE) (QUOTE safearray))
		  (IF (MINUSP (vlax-safearray-get-u-bound VALUE 1))
		    nil
		    (vlax-safearray->list VALUE)
		  )
		 )
		 (T VALUE)
	   )
    )
    VAR
  )
)

(defun c:k_blkadd (/ A ARRAY BLK BLK_BEZ DOCUMENT_OBJEKT ENT_NAME I OBJ_LIST OBJ_NAME P	PP PQ PX PY PZ SATZ TEMP TEMP_INS)
;;; Objekte zu Blockdefinitionen hinzufügen
  (vla-startundomark (k_ac-doc))
  (setq	document_objekt
	 (k_ac-doc)
  )
  (setq satz (ssget))
  (while (or (null obj_name)
	     (and obj_name
		  (/= (vla-get-objectname obj_name) "AcDbBlockReference")
	     )
	 )
    (setq
      obj_name (vlax-ename->vla-object (setq ent_name (car (entsel))))
    )
  )
  (k_mem_laystat)
  (vlax-for lay	(vla-get-layers (k_ac-doc))
    (vla-put-lock lay :vlax-false)
  )
  (ssdel ent_name satz)
  (if (tblsearch "UCS" "k_blkadd")
    (command "_ucs" "_delete" "k_blkadd")
  )
  (command "_ucs" "_save" "k_blkadd")
  (command "_ucs" "_object" ent_name)
  (mapcar 'set
	  '(pq px py pz)
	  (mapcar '(lambda (p)
		     (trans p 1 0)
		   )
		  '((0 0 0) (1 0 0) (0 1 0) (0 0 1))
	  )
  )
  (command "_ucs" "_w")
  (setq temp_ins (k_temp-blk satz))
  (mapcar 'vla-erase (k_satz->objlist satz))
;;;;;; um Z-Achse rotieren damit X in Draufsicht auf X-Achse
  (setq a (- 0.0 (angle pq px)))
  (setq pp (mapcar '+ pq '(0 0 1)))
  (mapcar 'set
	  '(px py pz)
	  (mapcar '(lambda (p) (k_p_twist p pq (- 0.0 (angle pq px))))
		  (list px py pz)
	  )
  )
  (vla-Rotate3D
    temp_ins
    (vlax-3d-point pq)
    (vlax-3d-point pp)
    a
  )

;;;;;; um Y-Achse rotieren damit X in Frontansicht auf X-Achse
  (setq a (- 0.0 (angle (k_nth pq '(0 2 1)) (k_nth px '(0 2 1)))))
  (setq pp (mapcar '+ pq '(0 1 0)))
  (mapcar 'set
	  '(px py pz)
	  (mapcar '(lambda (p)
		     (k_nth (k_p_twist (k_nth p '(0 2 1))
				       (k_nth pq '(0 2 1))
				       (- 0.0 (angle (k_nth pq '(0 2 1)) (k_nth px '(0 2 1))))
			    )
			    '(0 2 1)
		     )
		   )
		  (list px py pz)
	  )
  )
  (vla-Rotate3D
    temp_ins
    (vlax-3d-point pq)
    (vlax-3d-point pp)
    (- 0 a)
  )

;;;;;; um X-Achse rotieren damit Y und Z auf jeweiliger Achse
  (setq a (- 0.0 (angle (k_nth pq '(1 2 0)) (k_nth py '(1 2 0)))))
  (setq pp (mapcar '+ pq '(1 0 0)))
  (mapcar 'set
	  '(px py pz)
	  (mapcar '(lambda (p)
		     (k_nth (k_p_twist (k_nth p '(1 2 0))
				       (k_nth pq '(1 2 0))
				       (- 0.0 (angle (k_nth pq '(1 2 0)) (k_nth py '(1 2 0))))
			    )
			    '(2 0 1)
		     )
		   )
		  (list px py pz)
	  )
  )
  (vla-Rotate3D
    temp_ins
    (vlax-3d-point pq)
    (vlax-3d-point pp)
    a
  )

;;; temporäres Insert an WKS ausgerichtet

  (vla-move temp_ins
	    (vlax-3d-point pq)
	    (vlax-3d-point '(0 0 0))
  )
  (setq obj_list (k_explode temp_ins))
  (vla-delete temp_ins)
  (setq temp_ins (k_temp-blk obj_list))
  (mapcar 'vla-erase obj_list)
  (vla-put-XScaleFactor
    temp_ins
    (/ 1.0 (vla-get-XScaleFactor obj_name))
  )
  (vla-put-YScaleFactor
    temp_ins
    (/ 1.0 (vla-get-YScaleFactor obj_name))
  )
  (vla-put-ZScaleFactor
    temp_ins
    (/ 1.0 (vla-get-ZScaleFactor obj_name))
  )
  (vla-move temp_ins
	    (vlax-3d-point '(0 0 0))
	    (vla-get-origin (k_get-def obj_name nil))
  )

  (setq obj_list (k_explode temp_ins))
  (vla-delete temp_ins)
  (k_ofang "mem")
  (k_ofang "aus")
  (setq blk_bez (vla-get-effectivename obj_name))
  (setq blk (vla-item (vla-get-blocks document_objekt) blk_bez))
  (if (= (vla-get-islayout blk) :vlax-false)
    (progn
      (setq ARRAY (vl-catch-all-apply
		    'vlax-make-safearray
		    (list
		      vlax-vbobject
		      (cons 0 (1- (length obj_list)))
		    )
		  )
      )
      (setq i -1)
      (mapcar '(lambda (A)
		 (vlax-safearray-put-element
		   ARRAY
		   (setq i (1+ i))
		   A
		 )
	       )
	      obj_list
      )
      (not (vl-catch-all-error-p
	     (vl-catch-all-apply
	       'vla-copyobjects
	       (list
		 document_objekt
		 ARRAY
		 blk
	       )
	     )
	   )
      )
      (mapcar 'vla-delete temp)
    )
  )
  (command "_attsync" "_n" blk_bez)
  (mapcar 'vla-erase obj_list)
  (k_ofang "restore")
  (redraw)
  (if (tblsearch "UCS" "k_blkadd")
    (progn
      (command "_ucs" "_restore" "k_blkadd")
      (command "_ucs" "_delete" "k_blkadd")
    )
  )
  (k_rst_laystat)
  (vla-endundomark (k_ac-doc))
  (princ)
)
;;; - ------------------------------------------------------------------------------ - ;
(princ
  (strcat
    "\nk_blkadd:  Objekte zu Block hinzufügen"
    "\n===========  "
    "\n(C) Andreas Kraus 2024 (info@kraus-cad.de)"
    "\nBefehlszeilenaufruf : k_blkadd\n"
  )
)
;;; - ------------------------------------------------------------------------------ - ;
(princ)
