;;; - ------------------------------------------------------------------------------ - ;
;;; -                 T O O L - K_CO                                                 - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Beschreibung :  Zeichnung neu über „copyobjects“                               - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Befehle      :  k_co                                                           - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - letzte Änderung am : 09.09.2023                                                - ;
;;; -              durch : Andreas Kraus                                             - ;
;;; - ------------------------------------------------------------------------------ - ;

(DEFUN I-CDR (LST) (REVERSE (CDR (REVERSE LST))))
(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_ABSOLUTEPATH (REFERENZPFAD REL_PFAD / DUMMY LW REFERENZPFAD_LIST)
  (IF (OR (VL-STRING-SEARCH "./" REL_PFAD)
	  (VL-STRING-SEARCH "../" REL_PFAD)
	  (VL-STRING-SEARCH ".\\" REL_PFAD)
	  (VL-STRING-SEARCH "..\\" REL_PFAD)
      )
    (PROGN (IF (NOT (VL-FILE-DIRECTORY-P REFERENZPFAD))
	     (SETQ REFERENZPFAD (VL-FILENAME-DIRECTORY REFERENZPFAD))
	   )
	   (SETQ REFERENZPFAD_LIST
		  (VL-REMOVE ""
			     (K_ZERLEGE_ART
			       (K_TXT-SUBST (K_PATHBACKSLASH REFERENZPFAD T) "\\" "/")
			       "/"
			       "str"
			     )
		  )
	   )
	   (SETQ LW (NTH 0 REFERENZPFAD_LIST))
	   (SETQ REFERENZPFAD_LIST (CDR REFERENZPFAD_LIST))
	   (FOREACH REL	(K_ZERLEGE_ART (K_TXT-SUBST REL_PFAD "\\" "/") "/" "str")
	     (COND ((= REL "..")
		    (SETQ REFERENZPFAD_LIST (I-CDR REFERENZPFAD_LIST))
		   )
		   ((= REL ".") nil)
		   (T
		    (SETQ REFERENZPFAD_LIST (APPEND REFERENZPFAD_LIST (LIST REL)))
		   )
	     )
	   )
	   (SUBSTR (APPLY (QUOTE STRCAT)
			  (MAPCAR (QUOTE (LAMBDA (DUMMY) (STRCAT "\\" DUMMY)))
				  (CONS LW REFERENZPFAD_LIST)
			  )
		   )
		   2
	   )
    )
    REL_PFAD
  )
)
(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_COUNTER_DIALOG	(TODO TXT1 TXT2)
  (DEFUN K_COUNTER_DIALOG_NEU nil
    (DONE_DIALOG)
    (NEW_DIALOG "k_counter_dialog" K_COUNTER_DLG)
    (SETQ K_COUNTER_DIALOG_N 0)
  )
  (COND	((AND (= (TYPE TODO) (QUOTE STR)) (= (STRCASE TODO) "START"))
	 (SETQ K_COUNTER_DLG
				      (LOAD_DIALOG "k_main.dcl")
	       K_COUNTER_DIALOG_N     0
	       K_COUNTER_DIALOG_TITEL TXT1
	 )
	 (COND ((AND TXT2 (= (TYPE TXT1) (QUOTE INT)))
		(SETQ K_COUNTER_DIALOG_X TXT2)
	       )
	       ((AND TXT2 (= (TYPE TXT1) (QUOTE STR)))
		(SETQ K_COUNTER_DIALOG_T TXT2)
	       )
	       (T (SETQ K_COUNTER_DIALOG_X nil))
	 )
	 (IF (NOT (NEW_DIALOG "k_counter_dialog" K_COUNTER_DLG))
	   (EXIT)
	 )
	 (IF K_COUNTER_DIALOG_TITEL
	   (SET_TILE "titel"
		     (VL-PRINC-TO-STRING K_COUNTER_DIALOG_TITEL)
	   )
	 )
	)
	((AND (= (TYPE TODO) (QUOTE STR)) (= (STRCASE TODO) "END"))
	 (DONE_DIALOG)
	 (IF K_COUNTER_DLG
	   (UNLOAD_DIALOG K_COUNTER_DLG)
	 )
	 (SETQ K_COUNTER_DIALOG_N nil
	       K_COUNTER_DLG	  nil
	 )
	)
	((AND (= (TYPE TODO) (QUOTE STR)) (= (STRCASE TODO) "SHOW"))
	 (SETQ K_COUNTER_DIALOG_N (1+ K_COUNTER_DIALOG_N))
	 (IF (AND K_COUNTER_DIALOG_X
		  (>= K_COUNTER_DIALOG_N K_COUNTER_DIALOG_X)
	     )
	   (K_COUNTER_DIALOG_NEU)
	 )
	 (SET_TILE "text1" (VL-PRINC-TO-STRING TXT1))
	 (SET_TILE "text2" (VL-PRINC-TO-STRING TXT2))
	)
	(T nil)
  )
)
(DEFUN K_E005 (DOC / DOC MEM_CLAYER MEM_DEF_LST OK APP_LIST)
  (DEFUN E005_MK_DEFLIST (/ DEF_LIST)
    (LIST (vla-get-Count (vla-get-Blocks DOC))
	  (vla-get-Count (vla-get-DimStyles DOC))
	  (vla-get-Count (vla-get-Layers DOC))
	  (vla-get-Count (vla-get-Linetypes DOC))
	  (vla-get-Count (vla-get-TextStyles DOC))
	  (vla-get-Count
	    (vla-Item (vla-get-Dictionaries DOC) "ACAD_MLINESTYLE")
	  )
	  (vla-get-Count
	    (vla-Item (vla-get-Dictionaries DOC) "ACAD_TABLESTYLE")
	  )
	  (vla-get-Count (vla-get-RegisteredApplications DOC))
    )
  )
  (IF (NULL DOC)
    (SETQ DOC (K_AC-DOC))
  )
  (SETQ MEM_CLAYER (vla-get-ActiveLayer DOC))
  (vla-put-ActiveLayer
    DOC
    (vla-Item (vla-get-Layers DOC) "0")
  )
  (K_GRP_PURGE DOC)
  (K_IMAGE_PURGE DOC)
  (K_LAYOUT_PURGE DOC)
  (SETQ OK T)
  (WHILE OK
    (SETQ MEM_DEF_LST (E005_MK_DEFLIST))
    (vla-PurgeAll DOC)
    (IF	(EQUAL DOC (K_AC-DOC))
      (COMMAND "_purge" "_r" "*" "_n")
      (PROGN (SETQ N (LENGTH
		       (SETQ APP_LIST (K_COLLECTION->LIST (vla-get-RegisteredApplications DOC)))
		     )
	     )
	     (K_COUNTER_DIALOG "start" "Apps bereinigen" nil)
	     (FOREACH APP APP_LIST
	       (K_COUNTER_DIALOG "show" (ITOA (SETQ N (1- N))) "")
	       (VL-CATCH-ALL-APPLY (QUOTE vla-Delete) (LIST APP))
	     )
	     (K_COUNTER_DIALOG "end" nil nil)
      )
    )
    (IF	(EQUAL MEM_DEF_LST (SETQ MEM_DEF_LST (E005_MK_DEFLIST)))
      (SETQ OK nil)
    )
  )
  (IF (AND (K_->ENT_NAME MEM_CLAYER) (vla-get-Name MEM_CLAYER))
    (vla-put-ActiveLayer DOC MEM_CLAYER)
  )
)
(DEFUN K_GET-FULLNAME (DOCUMENT / NAME)
  (IF (NULL DOCUMENT)
    (SETQ DOCUMENT (K_AC-DOC))
  )
  (IF (vlax-property-available-p DOCUMENT "fullname")
    (IF	(= (SETQ NAME (vla-get-FullName DOCUMENT)) "")
      (IF (vlax-property-available-p DOCUMENT "name")
	(SETQ NAME (vla-get-Name DOCUMENT))
      )
    )
    (IF	(vlax-property-available-p DOCUMENT "name")
      (SETQ NAME (vla-get-Name DOCUMENT))
    )
  )
  (K_TXT-SUBST NAME "\\" "/")
)
(DEFUN K_GET_ASSOC (LISTE GRUPPE)
  (IF (/= (TYPE GRUPPE) (QUOTE LIST))
    (SETQ GRUPPE (LIST GRUPPE))
  )
  (VL-REMOVE-IF-NOT
    (QUOTE (LAMBDA (DATA) (MEMBER (CAR DATA) GRUPPE)))
    LISTE
  )
)
(DEFUN K_GET_INTERFACE_OBJECT nil
  (vla-GetInterfaceObject
    (vlax-get-acad-object)
    (STRCAT "ObjectDBX.AxDbDocument."
	    (SUBSTR (GETVAR (QUOTE ACADVER)) 1 2)
    )
  )
)
(DEFUN K_GRP_PURGE (DOC)
  (IF (NULL DOC)
    (SETQ DOC (K_AC-DOC))
  )
  (VLAX-FOR GRP	(vla-Item (vla-get-Dictionaries DOC) "ACAD_GROUP")
    (IF	(= (vla-get-Count GRP) 0)
      (vla-Delete GRP)
    )
  )
  (PRINC)
)
(DEFUN K_IMAGE_PURGE (DOC / DATA DUMMY PATH)
  (IF (NULL DOC)
    (SETQ DOC (K_AC-DOC))
  )
  (IF (MEMBER "ACAD_IMAGE_DICT"
	      (VL-REMOVE (QUOTE nil)
			 (MAPCAR (QUOTE	(LAMBDA	(OBJ)
					  (IF (vlax-property-available-p OBJ "name")
					    (vla-get-Name OBJ)
					  )
					)
				 )
				 (K_COLLECTION->LIST (vla-get-Dictionaries DOC))
			 )
	      )
      )
    (FOREACH IMAGE (K_COLLECTION->LIST
		     (vla-Item (vla-get-Dictionaries DOC) "ACAD_IMAGE_DICT")
		   )
      (SETQ DATA  (ENTGET (K_->ENT_NAME IMAGE))
	    PATH  (CDR (ASSOC 1 DATA))
	    DUMMY nil
      )
      (REPEAT (1+ (VL-POSITION (QUOTE (102 . "{ACAD_REACTORS")) DATA))
	(SETQ DATA (CDR DATA))
      )
      (REPEAT (VL-POSITION (QUOTE (102 . "}")) DATA)
	(SETQ DUMMY (CONS (CAR DATA) DUMMY)
	      DATA  (CDR DATA)
	)
      )
      (IF (OR (= (LENGTH DUMMY) 1)
	      (VL-EVERY	(QUOTE NULL)
			(MAPCAR	(QUOTE ENTGET)
				(MAPCAR	(QUOTE CDR)
					(K_GET_ASSOC
					  (APPLY (QUOTE APPEND)
						 (VL-REMOVE-IF-NOT
						   (QUOTE
						     (LAMBDA (DAT) (= (CDR (ASSOC 0 DAT)) "IMAGEDEF_REACTOR"))
						   )
						   (MAPCAR (QUOTE ENTGET) (MAPCAR (QUOTE CDR) DUMMY))
						 )
					  )
					  330
					)
				)
			)
	      )
	      (NOT
		(FINDFILE (K_ABSOLUTEPATH
			    (VL-FILENAME-DIRECTORY (K_GET-FULLNAME DOC))
			    PATH
			  )
		)
	      )
	  )
	(vla-Delete IMAGE)
      )
    )
  )
)
(DEFUN K_IS (WERT)
  (COND	((= WERT :vlax-false) nil)
	((= WERT :vlax-true) T)
	((= WERT nil) nil)
	((= WERT T) T)
	((= WERT 1) T)
	((= WERT 0) nil)
	((= WERT "1") T)
	((= WERT "0") nil)
	((= (STRCASE WERT) "JA") T)
	((= (STRCASE WERT) "NEIN") nil)
  )
)
(DEFUN K_LAYOUT_PURGE (DOC)
  (IF (NULL DOC)
    (SETQ DOC (K_AC-DOC))
  )
  (FOREACH LAYOUT (CDR
		    (VL-SORT (VL-REMOVE-IF
			       (QUOTE
				 (LAMBDA (LAYOUT)
				   (EQUAL (vla-get-ModelSpace DOC) (vla-get-Block LAYOUT))
				 )
			       )
			       (K_COLLECTION->LIST (vla-get-Layouts DOC))
			     )
			     (QUOTE (LAMBDA (LAYOUT1 LAYOUT2)
				      (> (vla-get-Count (vla-get-Block LAYOUT1))
					 (vla-get-Count (vla-get-Block LAYOUT2))
				      )
				    )
			     )
		    )
		  )
    (IF	(< (vla-get-Count (vla-get-Block LAYOUT)) 2)
      (vla-Delete LAYOUT)
    )
  )
)
(DEFUN K_MK_SUBSTR_LIST	(TEXT FILTER ENTF / F_LIST ERGEBNIS_LIST POS START)
  (IF (WCMATCH TEXT FILTER)
    (PROGN (SETQ F_LIST	(K_WCMATCH_POS TEXT FILTER)
		 POS	1
	   )
	   (FOREACH TEIL F_LIST
	     (SETQ START (NTH 0 TEIL))
	     (IF (> START POS)
	       (SETQ ERGEBNIS_LIST (CONS (LIST POS (- START POS)) ERGEBNIS_LIST))
	       (SETQ ERGEBNIS_LIST (CONS (LIST POS 0) ERGEBNIS_LIST))
	     )
	     (IF ENTF
	       (SETQ ERGEBNIS_LIST (CONS TEIL ERGEBNIS_LIST))
	     )
	     (SETQ POS (+ START (NTH 1 TEIL)))
	   )
	   (IF (<= (SETQ START (+ (NTH 0 (LAST F_LIST)) (NTH 1 (LAST F_LIST))))
		   (STRLEN TEXT)
	       )
	     (SETQ ERGEBNIS_LIST (CONS (LIST START nil) ERGEBNIS_LIST))
	   )
	   (VL-REMOVE-IF
	     (QUOTE (LAMBDA (DUMMY) (= (CADR DUMMY) 0)))
	     (REVERSE ERGEBNIS_LIST)
	   )
    )
    (QUOTE ((1 nil)))
  )
)
(DEFUN K_PATHBACKSLASH (PFAD REMOVE)
  (IF (AND PFAD (/= PFAD ""))
    (PROGN (SETQ PFAD (K_TXT-SUBST PFAD "/" "\\"))
	   (COND ((AND REMOVE (= (SUBSTR PFAD (STRLEN PFAD) 1) "\\"))
		  (SETQ PFAD (SUBSTR PFAD 1 (1- (STRLEN PFAD))))
		 )
		 ((AND (NOT REMOVE) (/= (SUBSTR PFAD (STRLEN PFAD) 1) "\\"))
		  (SETQ PFAD (STRCAT PFAD "\\"))
		 )
	   )
    )
  )
  PFAD
)
(DEFUN K_P_TWIST (P PX WX)
  (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_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_TXT-SUBST (TXT ALT NEU)
  (WHILE (NOT (EQUAL TXT (SETQ TXT (VL-STRING-SUBST NEU ALT TXT))))
  )
  TXT
)
(DEFUN K_WCMATCH_POS (TEXT FILTER / START LISTE INC)
  (DEFUN K_WCMATCH_POS_WORK (TEXT / LISTE N TXT)
    (SETQ N (STRLEN TEXT))
    (WHILE (AND	(/= (SUBSTR TEXT 1 N) "")
		(WCMATCH (SUBSTR TEXT 1 N) FILTER)
	   )
      (SETQ N (1- N))
    )
    (SETQ TXT (SUBSTR TEXT 1 (1+ N))
	  N   1
    )
    (WHILE (AND (<= N (STRLEN TEXT)) (WCMATCH (SUBSTR TXT N) FILTER))
      (SETQ N (1+ N))
    )
    (SETQ START	(1- N)
	  INC	(+ INC START)
	  LISTE	(LIST (LIST INC (STRLEN (SUBSTR TXT START))))
	  INC	(+ INC (1- (STRLEN (SUBSTR TXT START))))
    )
    (IF	(AND (/= ""
		 (SETQ TEXT (SUBSTR TEXT (+ START (STRLEN (SUBSTR TXT START)))))
	     )
	     (WCMATCH TEXT FILTER)
	)
      (SETQ LISTE (APPEND LISTE (K_WCMATCH_POS_WORK TEXT)))
    )
    LISTE
  )
  (IF (= (STRLEN TEXT) 0)
    (SETQ LISTE (LIST (LIST 1 0)))
    (IF	(= FILTER "*")
      (SETQ LISTE (LIST (LIST 1 (STRLEN TEXT))))
      (PROGN (SETQ INC 0)
	     (IF (WCMATCH TEXT FILTER)
	       (PROGN (SETQ LISTE (K_WCMATCH_POS_WORK TEXT)))
	     )
      )
    )
  )
  LISTE
)
(DEFUN K_ZERLEGE_ART (ZEILE TRENNER ART / LISTE)
  (SETQ	LISTE (VL-REMOVE ""
			 (K_ZERLEGE_TEXT ZEILE (STRCAT "*" TRENNER "*") 2)
	      )
  )
  (COND	((= ART "int") (SETQ LISTE (MAPCAR (QUOTE ATOI) LISTE)))
	((= ART "real") (SETQ LISTE (MAPCAR (QUOTE ATOF) LISTE)))
	((= ART "str") (SETQ LISTE LISTE))
	(T nil)
  )
  LISTE
)
(DEFUN K_ZERLEGE_TEXT (TEXT FILTER RÜCKGABE / TEIL)
  (COND	((= RÜCKGABE 0)
	 (MAPCAR (QUOTE
		   (LAMBDA (TEIL) (SUBSTR TEXT (NTH 0 TEIL) (NTH 1 TEIL)))
		 )
		 (K_MK_SUBSTR_LIST TEXT FILTER T)
	 )
	)
	((= RÜCKGABE 1)
	 (MAPCAR (QUOTE
		   (LAMBDA (TEIL) (SUBSTR TEXT (NTH 0 TEIL) (NTH 1 TEIL)))
		 )
		 (K_WCMATCH_POS TEXT FILTER)
	 )
	)
	((= RÜCKGABE 2)
	 (MAPCAR (QUOTE
		   (LAMBDA (TEIL) (SUBSTR TEXT (NTH 0 TEIL) (NTH 1 TEIL)))
		 )
		 (K_MK_SUBSTR_LIST TEXT FILTER nil)
	 )
	)
	((= RÜCKGABE 3)
	 (MAPCAR (QUOTE (LAMBDA (TEIL) (LIST (NTH 0 TEIL) (NTH 1 TEIL))))
		 (K_MK_SUBSTR_LIST TEXT FILTER T)
	 )
	)
	((= RÜCKGABE 4)
	 (MAPCAR (QUOTE (LAMBDA (TEIL) (LIST (NTH 0 TEIL) (NTH 1 TEIL))))
		 (K_WCMATCH_POS TEXT FILTER)
	 )
	)
	((= RÜCKGABE 5)
	 (MAPCAR (QUOTE (LAMBDA (TEIL) (LIST (NTH 0 TEIL) (NTH 1 TEIL))))
		 (K_MK_SUBSTR_LIST TEXT FILTER nil)
	 )
	)
  )
)
(DEFUN _SETCLIPBOARDTEXT (TEXT / HTMLFILE RESULT)
  (SETQ	RESULT (vlax-invoke
		 (vlax-get (vlax-get (SETQ HTMLFILE (vlax-create-object "htmlfile"))
				     (QUOTE PARENTWINDOW)
			   )
			   (QUOTE CLIPBOARDDATA)
		 )
		 (QUOTE SETDATA)
		 "Text"
		 TEXT
	       )
  )
  (vlax-release-object HTMLFILE)
  TEXT
)

(defun c:k_co (/ DBX_INTERFACE ENT_NAME	LAYER OBJ OBJ_LIST OBJ_QUELL_NAME PFAD QUELL_LAYER QUELL_LAYER_LIST QUELL_LAYOUT_LIST VP_NR VP_OBJ VP_OBJ_LIST
	       VP_ZIEL_DATA ZIEL ZIEL_LAYOUT_LIST)
;;; Dateiinhalt in Zeichnung holen über ODBX
  (if (setq pfad (getfiled "Datei wählen" (getvar "DWGPREFIX") "dwg" 2))
    (if	(vl-file-rename pfad pfad)
      (progn
	(vlax-for layer	(vla-get-layers (k_ac-doc))
	  (if (/= (vla-get-name layer) (getvar "clayer"))
	    (vla-put-freeze layer :vlax-false)
	  )
	  (vla-put-Lock layer :vlax-false)
	)
;;; alle Objekte in Zielzeichnung löschen
	(mapcar 'vla-delete (k_satz->objlist (ssget "x")))
	(k_e005 nil)
;;; Quellzeichnung öffnen
	(setq dbx_interface (k_get_interface_object))
	(vla-open dbx_interface pfad)
;;;  Layouts der Quelldatei
	(setq quell_layout_list nil)
	(vlax-for layout (vla-get-layouts dbx_interface)
	  (setq quell_layout_list (cons layout quell_layout_list))
	)
	(setq quell_layout_list
	       (vl-sort	quell_layout_list
			'(lambda (layout1 layout2)
			   (< (vla-get-TabOrder layout1)
			      (vla-get-TabOrder layout2)
			   )
			 )
	       )
	)

;;;  Layouts der Zieldatei ermitteln
	(setq ziel_layout_list nil)
	(vlax-for layout (vla-get-layouts (k_ac-doc))
	  (setq	ziel_layout_list
		 (cons (vla-get-name layout) ziel_layout_list)
	  )
	)
;;; nicht vorhandene Layouts anlegen
	(foreach layout	quell_layout_list
	  (if (not (member (vla-get-name layout) ziel_layout_list))
	    (vla-add (vla-get-layouts (k_ac-doc)) (vla-get-name layout))
	  )
	)
;;;  Layouts sortieren
	(foreach layout	quell_layout_list
	  (if (/= (vla-get-TabOrder layout) 0)
	    (vla-put-TabOrder
	      (vla-item	(vla-get-layouts (k_ac-doc))
			(vla-get-name layout)
	      )
	      (vla-get-TabOrder layout)
	    )
	  )
	)
;;; Layouts löschen die nicht in Quellzeichnung sind
	(vlax-for layout (vla-get-layouts (k_ac-doc))
	  (if (not (member (vla-get-name layout)
			   (mapcar 'vla-get-name quell_layout_list)
		   )
	      )
	    (vla-delete layout)
	  )
	)
;;; jedes Layout kopieren
;;;  (setq layout (nth 1 quell_layout_list))
	(print "jedes Layout kopieren")
	(princ)
	(foreach layout	quell_layout_list
	  (print layout)
	  (setq	obj_list    (vl-remove-if-not
			      '(lambda (obj_name)
				 (and (k_->ent_name obj_name)
				      (entget (k_->ent_name obj_name))
				 )
			       )
			      (k_collection->list (vla-get-block layout))
			    )
		ziel
			    (vla-get-block
			      (vla-item	(vla-get-layouts (k_ac-doc))
					(vla-get-name layout)
			      )
			    )
		vp_obj_list
			    (vl-remove 'nil
				       (mapcar '(lambda	(obj)
						  (if (= (vla-get-ObjectName obj) "AcDbViewport")
						    (progn
						      (if (assoc 340 (entget (k_->ent_name obj)))
							(list obj
							      (k_->obj_name (cdr (assoc 340 (entget (k_->ent_name obj)))))
							)
							obj
						      )
						    )
						  )
						)
					       obj_list
				       )
			    )
	  )
	  (k_copyobjects
	    (vl-remove-if
	      '(lambda (obj) (= (vla-get-ObjectName obj) "AcDbViewport"))
	      obj_list
	    )
	    dbx_interface
	    ziel
	    nil
	  )
;;;    Viewports
	  (foreach vp_quell_data (cdr (reverse vp_obj_list))
	    (if	(listp vp_quell_data)
	      (setq obj_quell_name
				   (car	(k_copyobjects
					  (list (cadr vp_quell_data))
					  dbx_interface
					  ziel
					  t
					)
				   )
		    vp_quell_data
				   (entget (vlax-vla-object->ename (car vp_quell_data))
					   '("ACAD")
				   )
	      )
	      (setq vp_quell_data
				   (entget (vlax-vla-object->ename vp_quell_data)
					   '("ACAD")
				   )
		    obj_quell_name nil
	      )
	    )
	    (setvar "ctab" (cdr (assoc 410 vp_quell_data)))
	    (command "_zoom" "_e")
	    (command "_-vports"
		     (mapcar '-
			     (cdr (assoc 10 vp_quell_data))
			     (list (/ (cdr (assoc 40 vp_quell_data)) 2.0)
				   (/ (cdr (assoc 41 vp_quell_data)) 2.0)
				   0.0
			     )
		     )
		     (mapcar '+
			     (cdr (assoc 10 vp_quell_data))
			     (list (/ (cdr (assoc 40 vp_quell_data)) 2.0)
				   (/ (cdr (assoc 41 vp_quell_data)) 2.0)
				   0.0
			     )
		     )
	    )
	    (setq vp_ziel_data (entget (setq ent_name (entlast)) '("ACAD"))
		  vp_obj       (vlax-ename->vla-object ent_name)
	    )
	    (vla-put-ViewportOn vp_obj :vlax-true)
	    (if	obj_quell_name
	      (command "_vpclip" ent_name (k_->ent_name obj_quell_name))
	    )
	    (if	(not (tblsearch "LAYER" (cdr (assoc 8 vp_quell_data))))
	      (vla-add (vla-get-layers (k_ac-doc))
		       (vla-get-layer (k_->obj_name vp_quell_data))
	      )
	    )
	    (vla-put-layer
	      vp_obj
	      (vla-get-layer (k_->obj_name vp_quell_data))
	    )
	    (vla-put-color
	      vp_obj
	      (vla-get-color (k_->obj_name vp_quell_data))
	    )
	    (setq vp_nr (cdr (assoc 69 vp_ziel_data)))
	    (command "_zoom" "_e")
	    (command "_zoom" "_o" ent_name "")
	    (command "_mspace")
	    (setvar "cvport" vp_nr)
	    (vla-put-TwistAngle vp_obj (cdr (assoc 51 vp_quell_data)))
	    (command "zoom"
		     "_c"
		     (mapcar '+
			     (mapcar '-
				     (k_p_twist	(cdr (assoc 12 vp_quell_data))
						'(0 0)
						(- 0 (cdr (assoc 51 vp_quell_data)))
				     )
				     (k_3d->2d (cdr (assoc 16 vp_quell_data)))
			     )
			     (k_3d->2d (cdr (assoc 17 vp_quell_data)))
		     )
		     (cdr (assoc 45 vp_quell_data))
	    )
	    (command "_pspace")
	    (command "_zoom" "_e")
	  )
	)
;;; XREFs mit Absolutpfaden
	(foreach xref (vl-remove-if-not
			'(lambda (blk) (k_is (vla-get-isxref blk)))
			(k_collection->list (vla-get-blocks (k_ac-doc)))
		      )
	  (vla-put-Path
	    xref
	    (k_absolutepath
	      pfad
	      (vla-get-Path
		(vla-item (vla-get-blocks dbx_interface)
			  (vla-get-name xref)
		)
	      )
	    )
	  )
	  (vla-Reload xref)
	)
;;; Layerschaltung übertragen
	(vla-put-activelayer
	  (k_ac-doc)
	  (vla-item (vla-get-layers (k_ac-doc)) "0")
	)
	(setq quell_layer_list
	       (mapcar '(lambda (layer) (list (vla-get-name layer) layer))
		       (k_collection->list (vla-get-layers dbx_interface))
	       )
	)
	(foreach layer (k_collection->list (vla-get-layers (k_ac-doc)))
	  (if (setq quell_layer (cadr (assoc (vla-get-name layer) quell_layer_list)))
	    (progn
	      (vla-put-LayerOn layer (vla-get-LayerOn quell_layer))
	      (vla-put-lock layer (vla-get-lock quell_layer))
	      (if (/= (vla-get-name layer) "0")
		(vla-put-freeze layer (vla-get-freeze quell_layer))
	      )
	      (vla-put-Plottable layer (vla-get-Plottable quell_layer))
	      (vla-put-description
		layer
		(vla-get-description quell_layer)
	      )
	    )
	  )
	)
;;; XREFs mit Pfaden aus Quelldatei
	(foreach xref (vl-remove-if-not
			'(lambda (blk) (k_is (vla-get-isxref blk)))
			(k_collection->list (vla-get-blocks (k_ac-doc)))
		      )
	  (vla-put-Path
	    xref
	    (vla-get-Path
	      (vla-item	(vla-get-blocks dbx_interface)
			(vla-get-name xref)
	      )
	    )
	  )
	)
;;; Quellzeichnung trennen
	(vlax-release-object dbx_interface)
	(setvar "tilemode" 1)
	(command "_zoom" "_e")
	(_SetClipBoardText pfad)
      )
      (alert "Datei ist schreibgeschützt")
    )
  )
  (princ)
)
;;; - ------------------------------------------------------------------------------ - ;
(princ
  (strcat
    "\nk_co:  Zeichnung neu über „copyobjects“"
    "\n===========  "
    "\n(C) Andreas Kraus 2023 (info@kraus-cad.de)"
    "\nBefehlszeilenaufruf : k_co\n"
  )
)
;;; - ------------------------------------------------------------------------------ - ;
(princ)