;;; - ------------------------------------------------------------------------------ - ;
;;; -                 T O O L - K_ROTATECOPY                                         - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Beschreibung :  Auf Kreisbahn kopieren                                         - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Befehle      :  k_rotatecopy                                                   - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - letzte Änderung am : 12.08.2025                                                - ;
;;; -              durch : Andreas Kraus                                             - ;
;;; - ------------------------------------------------------------------------------ - ;

(vl-load-com)
(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_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 work_beginRightClick (dummy1 dummy2)
  (setq k_rmt t)
)
(DEFUN K_RMT_END nil
  (IF BEGINRIGHTCLICK
    (VLR-Remove BEGINRIGHTCLICK)
  )
)
(DEFUN K_RMT_START nil
  (SETQ K_RMT nil)
  (SETQ	BEGINRIGHTCLICK
	 (VLR-Mouse-Reactor
	   nil
	   (QUOTE
	     ((:VLR-beginRightClick . WORK_BEGINRIGHTCLICK))
	   )
	 )
  )
)
(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 c:k_rotatecopy (/ BLK-NAME K_RMT P SATZ Z)
;;;  kopiere auf Kreisbahn

  (defun k_x007_entmake	()
    (entmake (list
	       '(0 . "INSERT")
	       '(100 . "AcDbEntity")
	       '(67 . 0)
	       '(410 . "Model")
	       '(8 . "0")
	       '(100 . "AcDbBlockReference")
	       (cons 2 blk-name)
	       (cons 10 z)
	       '(41 . 1.0)
	       '(42 . 1.0)
	       '(43 . 1.0)
	       '(50 . 0.0)
	       '(70 . 0)
	       '(71 . 0)
	       '(44 . 0.0)
	       '(45 . 0.0)
	       '(210 0.0 0.0 1.0)
	     )
    )
  )

  (setq satz (ssget))
  (setq z (getpoint "Zentrum von Kreisbahn : "))
  (print)
  (setq p (getpoint "Startrichtung : "))
;;; unbenannten Block erzeugen
  (entmake
    (list
      (cons 0 "BLOCK")
      (cons 70 3)
      (cons 2 "*U")
      (cons 10 z)
    )
  )
  (setq blk-name (entmake (list (cons 0 "endblk"))))
;;; Elemente in Block kopieren
  (foreach ent_name (k_satz->entlist satz)
    (k_copyobjects
      ent_name
      nil
      (vla-item (vla-get-blocks (k_ac-doc)) blk-name)
      nil
    )
  )
  (k_rmt_start)
  (vla-startundomark (k_ac-doc))
;;; Block einfügen und drehen
  (while (null k_rmt)
    (k_x007_entmake)
    (print "Beenden mit Rechtsklick")
    (command "_rotate" "_l" "" z "b" z p "\\")
    (if	k_rmt
      (command-s "_erase" "_l" "")
      (command-s "_explode" "_l")
    )
  )
  (vla-endundomark (k_ac-doc))
  (k_rmt_end)
  (princ)
)
;;; - ------------------------------------------------------------------------------ - ;
(princ
  (strcat
    "\nk_rotatecopy:  Auf Kreisbahn kopieren"
    "\n===========  "
    "\n(C) Andreas Kraus 2024 (info@kraus-cad.de)"
    "\nBefehlszeilenaufruf : k_rotatecopy\n"
  )
)
;;; - ------------------------------------------------------------------------------ - ;
(princ)