; Programm: 		ACM_BTeilen.lsp
; Funktion: 		Tool zum Einfügen von Blöcken entlang von Polyliniensegmenten
; Autor: 	 		Silke Molch
; Lauffähig:		AutoCAD 2024[de] auf acadiso.dwt-Basis		
; Bezug:   			nur auf Tool-CD 5/2023
; ========================================================================================================================================

(defun 		c:ACM_BTeilen	; Aufruf
				( / )			(vl-load-com)
								(vl-cmdf "_UNDO" "b")	
							
	(setq 		xe  			; Aufruf Hauptroutine
								(vl-catch-all-apply 'f_algo '() )  )    	
								(if (vl-catch-all-error-p xe) 
									(progn (vl-cmdf "_UNDO" "r")
										(prompt (strcat "\n" (f_t) "-" (f_z)"\t : not ok >> " (vl-catch-all-error-message xe)))
									)
									(progn (vl-cmdf "_UNDO" "e")
										(setq tool_ xz)
										(f_xv_zuruecksetzen)
										(prompt (strcat "\n" (f_t) "-" (f_z)"\t : ok "))
									)
								)
								(f_var_undef)
								(princ)	
)

; ============================    Tool-Voreinstellung
(defun		f_var_xz_init		; Toolzustand voreinstellen
				( / )			; (cadr (assoc '"lang" xz))
	(setq		xz				(list												; _____________________________________________________________
									'("1" "2")										; Teilungsanzahl
									'("2" "1")										; Blockfaktor
									'("3" "0")										; Drehwinkel
									;("4" "0")										; 							
																					; _____________________________________________________________
									'("-1" "de")									; Sprache
									'("-2" "")										; Blockauswahl	
									'("-3" "ausgerichtet")							; Blockeindrehmodus										
																					; _____________________________________________________________
									'("AListe" (1 2 3))								; A-Liste der DCL-Auswahlobjekte (Elementeauflistung A1 A2 ...)
									'("EListe" (1 2 3 ))							; E-Liste der DCL-Eingabeobjekte (Elementeauflistung E1 E2 ...)			
									'("tool" "Toolname")							; Toolname
									'("logtofile" "off")							; Protokollierung 
									'("logtoscreen" "off")	
								)
	)
	(setq 		xp				(list "f_var_xm_init" '())			
				r				xz )		
)
(defun		f_var_xm_init		; Message-Begriffe definieren
				( / )			; (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '1 xm))))
	(setq		xm				(list
									'(1 ("de" "Tool-Einstellung")						("en" "Tool Setting"))
									'(2 ("de" "DCL-Datei konnte nicht erstellt werden!")("en" "Could not create .dcl file!"))
									'(3 ("de" "Verwerfen")								("en" "Discard"))
									'(4 ("de" "Originalwerte")							("en" "Original values"))
									'(5 ("de" "Hilfe")									("en" "Help"))
									'(6 ("de" "Ausführen")								("en" "Execute"))
									'(7 ("de" "Exit")									("en" "Exit"))
									'(8 ("de" "Speichern")								("en" "Save"))																		
									'("A1" 		("de" 	" Sprache :  ")					)	
									'("A2" 		("de" 	" Blockauswahl : ")				)	
									'("A3" 		("de" 	" Blockausrichtungsmodus : ")	)										
									
									'("E1" 		("de" 	" Segment-Anzahl >= 2 : ")			)
									'("E2" 		("de" 	" Blockfaktor >0 : ")			)
									'("E3" 		("de" 	" Blockdrehwinkel 0 ... 360° : "))
									
									;'("E4" 		("de" 	" Nummerierungsinkrementzahl : >=1 ")		)
									;'("E5" 		("de" 	" max. Durchmessertoleranz >0 : ")	)
									;'("E6" 		("de" 	" max. Segmenthöhentoleranz >0 : ")	)	
									;'("E7" 		("de" 	" max. Lot-Abweichungstoleranz >0 : ")	)									
									
									'("m_1" ("de"   "\nBitte wählen Sie das Objekt aus: >> ")	
									)											

									'("m-1" ("de"  	"Es wurde kein Objekt gewählt! ")	
									)
									'("m-2" ("de"  	"\nEs wurde kein zulässiges Objekt gewählt! ")	
									)
									'("m-3" ("de"  	"\nEs konnten keine Blöcke gefunden werden! ")	
									)									
									
									'("e_lz" ("de"  "\nEs konnte keine DCL-Datei erstellt werden! ")	
									)											
								)
	)
	(setq 		xp				(list "f_var_xm_init" '())		
				r				xm )	
)
(defun		f_var_xh_init		; Help-Text definieren
				( / )
	(setq		xh				(list
									(list "de" (strcat

										"\nTool ACM_BTeilen.lsp  "
										"\n"
										"\n_________________________"
										"\tVoreinstellungen/Modi: \n"
										"\nSprache:              \t\tdeutsche Sprache"	
										"\nBlockauswahl:  	\t..."	
										"\nBlockausrichtungsmodus:\tausgerichtet"	
										"\n\t\t\tnicht ausgerichtet "																					
										"\n_________________________"
										"\tEinstellungen:\n"		
										"\nSegment-Anzahl >=2:  \t..."	
										"\nBlockfaktor >0:  \t\t..."
										"\nBlockdrehwinkel 0...360°:  \t..."										
										"\n"
										"\n_________________________"
										"\tButton:\n"
										"\nAusführen \t\tAktion ausführen"
										"\nSpeichern           \t\tSpeichern der voreingestellten Werte"
										"\nOriginalwerte \t\tZurücksetzen auf die Originalwerte"
										"\nVerwerfen \t\tZurücksetzen auf vorherige Einstellung"
										"\nHilfe \t\t\tAnzeige der Hilfe"
										"\nExit \t\t\tVerlassen des Tools"									
										
										"\n"
										"\n_________________________"										
										"\tInformation:\n"
										"\n"

"Das Tool fügt je nach Voreinstellung entlang jedes einzelnen Polyliniensegmentes einen ausgewählten Block entsprechend "
"der vorbestimmten Aufteilungsanzahl pro Polyliniensegment auf dem aktuellen Layer ein. "
"Dabei kann der Blockskalierungsfaktor sowie der Drehwinkel für die einzufügenden Blöcke vorab festgelegt werden. "
"Der voreingestellte Drehwinkel kommt dabei aber nur zum Tragen, wenn der Blockausrichtungsmodus auf „nicht ausgerichtet“ eingestellt wurde. "
"Bei einem ausgewählten „ausgerichtet“-Modus werden die Blöcke entsprechend der Polyliniensegmentausrichtung eingedreht. "
"Sollte der Layer der Polylinie gesperrt sein, so wird dieser Layer automatisch entsperrt."

 


										"\n\nKontakt: \t\t\tIKT-Service@gmx.de"

										)
									)
									(list "en" (strcat
										"\nTool "
										"\n"	
										
										"\n"
										"\nButton:"
										"\n"
										"\nExecute \t\tExecute"
										"\nSave    \tSave the value"
										"\nOriginal value \tZurücksetzen auf die Originalwerte / Goldener Schnitt"
										"\nVerwerfen \tReturn to the original values"
										"\nHelp\t\tShow the help"
										"\n...  \t\tShowing the help"
										"\nExit \t\tClose the tool"
										"\n"
										"\nContakt: \t\tIKT-Service@gmx.de"
									))
								)
	)
	(setq 		xp				(list "f_var_xh_init" '())		
				r				xh )		
)
; ============================    Tool-Algorithmus
(defun		f_algo				; Allgemeiner Ablauf
				( / )			(setq return nil)
								(if (equal '(t t) 																						; Laufbedingung
										(list 
											(>= (atof(substr (getvar "acadver") 1 4)) 24.0)
											(<= (atof(substr (getvar "acadver") 1 4)) 24.3)
										)
									)
									(progn
										(f_var_def)(f_var_xs_init)
										
										(if (not (equal tool_ nil))																				; letzte Einstellung			
											(setq xz tool_)
											(f_var_xz_init)
										)
										
										(f (f_var_xm_init))(f (f_var_xh_init))
												
										(f (f_xv_def))(f (f_xv_sichern))(f (f_xv_setzen))

												
										(f (f_DCL_erstellen))(f (f_DCL_laden))
											
										(if (equal r t)
											(f (f_action))
										)
																						

									)
									(alert "Diese AutoCAD-Version wird nicht unterstützt!\nThis version of AutoCAD is not supported!\n\nService: IKT-Service@gmx.de")
								)
	(setq 		xp				(list "f_algo" '())								
				r				"OK" )							
)
(defun		f_action			; Toolablauf
			( / 
				x1 x2 x3 x4 x5 x6 x7 x18
				x8 x9 x10 x11 
			)			
			
						(if (not (equal (tblnext "block" t) nil))
							(progn
									(if (tblsearch "UCS" "tool_")
										(progn
											(vl-catch-all-apply (function (lambda nil 
																(vl-cmdf "bks" "sp" "tool_" "j")
															)	) 	)
										)
										(progn
											(vl-catch-all-apply (function (lambda nil 
																(vl-cmdf "bks" "sp" "tool_" )
															)	) 	)
										)										
									)			
									(terpri)(princ (cadadr (assoc "m_1" xm)))
									(setq x1 (entsel))
									
									(if (equal x1 nil)
										(progn
											(terpri)(princ (cadadr (assoc "m-1" xm)))
										)
										(progn
											(if (not (member (cdr (assoc '0 (entget (car x1))))
													 (list "LWPOLYLINE" "POLYLINE")
												))
												(progn
													(terpri)(princ (cadadr (assoc "m-2" xm)))
												)												
												(progn
													(vl-catch-all-apply (function (lambda nil 
														(vl-cmdf "-layer" "en" (cdr (assoc '8 (entget (car x1)))) "")
													)	) 	)
													(setq x2 (ssget "_ALL"))
													(vl-catch-all-apply (function (lambda nil 
														(vl-cmdf "kopieren" (car x1) "" "0,0,0" "0,0,0")
													)	) 	)
													(setq x3 (ssget "_ALL"))
													
													(if (> (sslength x3)(sslength x2))
														(progn
															(setq x18 (ssname (ssget "_L") 0))
															(if (equal (cdr (assoc '0 (entget (car x1)))) "POLYLINE")
																(progn
																	(vl-catch-all-apply (function (lambda nil 
																		(vl-cmdf "polykonvert" "d" x18 "")
																	)	) 	)
																)
															)
															(vl-catch-all-apply (function (lambda nil 
																(f_break x18)
															)	) 	)
														)
													)
													(setq x4 (ssget "_ALL"))
													(setq x5 (f_slistdelta x2 x4))
													;
													(setq x6 0)
													(while (< x6 (sslength x5))	
															(setq x7 (list 
																	(ssname x5 x6) 
																	(cdr (assoc '10 (entget (ssname x5 x6))))
															))
															(if (equal (cadr (assoc "-3" xz)) "ausgerichtet")
																(progn
																	(vl-catch-all-apply (function (lambda nil 
																		(vl-cmdf (getcname "teilen") x7 "b" 
																			(cadr (assoc "-2" xz)) "j" 
																			(cadr (assoc "1" xz))
																		)
																	)	) 	)	
																)
																(progn
																	(vl-catch-all-apply (function (lambda nil 
																		(vl-cmdf (getcname "teilen") x7 "b" 
																			(cadr (assoc "-2" xz)) "n" 
																			(cadr (assoc "1" xz))
																		)
																	)	) 	)	
																)
															)														
														(vl-cmdf "löschen" x7 "")
														(setq x6 (+ x6 1))
													)
													(setq x8 (ssget "_ALL"))
													(if (< (sslength x2)(sslength x8))
														(progn
															(setq x11 (f_slistdelta x2 x8))
													
															(setq x9 0)
															(while (< x9 (sslength x11))													
																(setq x10 (entget (ssname x11 x9)))
																(setq x10 (subst (cons 41 (atof (cadr (assoc "2" xz)))) (assoc 41 x10) x10))
																(setq x10 (subst (cons 42 (atof (cadr (assoc "2" xz)))) (assoc 42 x10) x10))
																(setq x10 (subst (cons 43 (atof (cadr (assoc "2" xz)))) (assoc 43 x10) x10))
																(if (equal (cadr (assoc "-3" xz)) "ausgerichtet")
																	(progn (setq x10 x10))
																	(progn
																		(setq x10 (subst (cons 50 
																			(* 	(/ (* 2.0 pi) 360.0)
																				(atof (cadr (assoc "3" xz)))
																			)
																			)
																			(assoc 50 x10) x10)
																		)
																	)
																)	
																(entmod x10)
																(entupd (ssname x11 x9))
																(setq x9 (+ x9 1))
															)
														)
													)
												)
											)	
										)
									)
								(vl-catch-all-apply (function (lambda nil 
														(vl-cmdf "bks" "ho" "tool_")
													)	) 	)
								(vl-catch-all-apply (function (lambda nil 
																(vl-cmdf "bks" "lö" "tool_" )
													)	) 	)
								(terpri)(princ ".............................................................................")
							)
							(progn
								(terpri)(princ (cadadr (assoc "m-3" xm)))
							)
						)
						
)
(defun		f_break				; Aufbrechen von LWPolylinien
			(x1 / 				; Objektname
			x1 x2 x3 x4 x5 x6
			)
								;(terpri)(princ "LWPolyline: >> ")
								;(setq x1 (ssname (ssget) 0))
								(setq x2 (vlax-safearray->list (vlax-variant-value (vlax-get-property (vlax-ename->vla-object x1) 'Coordinates ))))
								(setq x6 '())
								(setq x3 0)
								(while (< x3 (length x2))
									(setq x4 (list (nth x3 x2)(nth (+ x3 1) x2)))		
									(setq x5 (trans x4 x1 1))
									(setq x6 (cons x5 x6))
									(setq x3 (+ x3 2))
								)
								(setq x3 0)
								(while (< x3 (length x6))
									
									(vl-catch-all-apply (function (lambda nil 
										(vl-cmdf (getcname "bruch") x1 (nth x3 x6) "@0,0,0"
										)
									)	) 	)								
									(setq x3 (+ x3 1))
								)
)
(defun		f_tolstring			; String in String mit Elimenieren von Punkten, Kommas etc.
			(x1 / x1 x2 x3 x4)
								(setq x2 0 x3 "1234")
								(while (< x2 (strlen x1))
									(setq x4 (substr x1 (+ 1 x2) 1))
									(if (member x4 '( "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
										(progn
											(setq x3 (strcat x4 x3))
										)
									)
									(setq x2 (+ x2 1))
								)
								(setq return x3)
)	
(defun		f_xz_setzen			; xz setzen
			( x1 x2 / x1 x2 x3 x4)	; assco neuerWert
								(setq x3 0 x4 '())
								;(princ "\nListe vorher")(princ xz)
								(while (< x3 (length xz))
									(if (equal (nth 0 (nth x3 xz)) x1)
										(progn
											(setq x4 (cons (list x1 x2)	x4))
										)
										(progn
											(setq x4 (cons (nth x3 xz) x4))
										)
									)
									(setq x3 (+ x3 1))
								)
								(setq xz (reverse x4))
								;(princ "\nListe nachher")(princ xz)
								(terpri)
)
(defun 		f_split				; String zu Liste durch Trennzeichen
			( x1 x2 
			/ x3 x4 x5 )
								(setq x3 (1+ (strlen x2)))
								(while (setq x5 (vl-string-search x2 x1))
									(setq x4 (cons (substr x1 1 x5) x4)
										  x1 (substr x1 (+ x5 x3))
									)
								)
								(reverse (cons x1 x4))
)
(defun		f_zahl_zahlohnekomma	; Zahl in Zahl ohne Komma 
			(x1
			/ x1 x2)
								(setq x2
									(atoi
										(strcat
											(substr (rtos x1 2) 1 	(+ (strlen (rtos (fix x1) 2)) 0))
											(substr (rtos x1 2)		(+ (strlen (rtos (fix x1) 2)) 2))	
										)
									)
								)
			(setq r	x2	)			
)	
(defun		f_slistdelta		; Differenzliste L2 - L1 => Rest L2
			( x1 				; Liste 1 alt
			x2 					; Liste 2 neu
			/ x1 x2 x3 x4)
								(if (and (not (equal x1 nil))(not (equal x2 nil)))
									(progn
										(setq x3 x2 x4 0)
										(while (< x4 (sslength x1))
											(if (ssmemb (ssname x1 x4) x2)
												(progn
													(ssdel (ssname x1 x4) x3)
												)
											)
											(setq x4 (+ x4 1))
										)
									)
								)
	(setq 		xp				(list "f_slistdelta" (list x1 x2))
				r				x3)			
)																											
; ============================    DCL-Routinen
(defun		f_DCL_erstellen		; DCL_erstellen
				( / x1 x2)		
	(setq 		x2 			(open (cadr (assoc '"dcl" xs)) "w"))
							(if (/= x2 nil)
								(progn
									(setq x1
										(strcat 
											"//tool.dcl"
											"\ntool : dialog{"
												"\n						label = "	(chr 34) (f (f_xm 1)) (chr 34)	";"														
												"\n:boxed_row{"

													"\n:column{"			
														"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"A1" xm))))	(chr 34) ";}"
														"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"A2" xm))))	(chr 34) ";}"
														"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"A3" xm))))	(chr 34) ";}"																
														;"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"A4" xm))))	(chr 34) ";}"	
														;"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"A5" xm))))	(chr 34) ";}"														
														;"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"A6" xm))))	(chr 34) ";}"															
														;"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"A7" xm))))	(chr 34) ";}"	
														;"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"A8" xm))))	(chr 34) ";}"														
													"\n}"	
													"\n:column{"
														"\n:popup_list 	{ key=" 	(chr 34) "A1" (chr 34) "; label = " (chr 34) " " (chr 34) "; edit_width=29; }"		
														"\n:popup_list 	{ key=" 	(chr 34) "A2" (chr 34) "; label = " (chr 34) " " (chr 34) "; edit_width=29; }"		
														"\n:popup_list 	{ key=" 	(chr 34) "A3" (chr 34) "; label = " (chr 34) " " (chr 34) "; edit_width=29; }"		
														;"\n:popup_list 	{ key=" 	(chr 34) "A4" (chr 34) "; label = " (chr 34) " " (chr 34) "; edit_width=29; }"															
														;"\n:popup_list 	{ key=" 	(chr 34) "A5" (chr 34) "; label = " (chr 34) " " (chr 34) "; edit_width=29; }"
														;"\n:popup_list 	{ key=" 	(chr 34) "A6" (chr 34) "; label = " (chr 34) " " (chr 34) "; edit_width=29; }"														
														;"\n:popup_list 	{ key=" 	(chr 34) "A7" (chr 34) "; label = " (chr 34) " " (chr 34) "; edit_width=29; }"														
														;"\n:popup_list 	{ key=" 	(chr 34) "A8" (chr 34) "; label = " (chr 34) " " (chr 34) "; edit_width=29; }"																
													"\n}"													
												"\n}"	
										)
									)
									(princ x1 x2)
									(setq x1
										(strcat
												"\n:boxed_row{"											
													"\n:column{"	
														"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"E1" xm))))	(chr 34) ";}"													
														"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"E2" xm))))	(chr 34) ";}"																
														"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"E3" xm))))	(chr 34) ";}"																											
														;"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"E4" xm))))	(chr 34) ";}"		
														;"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"E5" xm))))	(chr 34) ";}"		
														;"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"E6" xm))))	(chr 34) ";}"		
														;"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"E7" xm))))	(chr 34) ";}"		
														;"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"E8" xm))))	(chr 34) ";}"		
														;"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"E9" xm))))	(chr 34) ";}"		
														;"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"E10" xm))))	(chr 34) ";}"		
														;"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"E11" xm))))	(chr 34) ";}"		
														;"\n:text		{ label="  	(chr 34) (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc '"E12" xm))))	(chr 34) ";}"																
													"\n}"
													"\n:column{"	
														"\n:edit_box	{ key=" 	(chr 34) "E1" (chr 34) "; label = " (chr 34) " " (chr 34) "; edit_width=30; }"	
														"\n:edit_box	{ key=" 	(chr 34) "E2" (chr 34) "; label = " (chr 34) " " (chr 34) "; edit_width=30; }"														
														"\n:edit_box	{ key=" 	(chr 34) "E3" (chr 34) "; label = " (chr 34) " " (chr 34) "; edit_width=30; }"
														;"\n:edit_box	{ key=" 	(chr 34) "E4" (chr 34) "; label = " (chr 34) " " (chr 34) "; edit_width=30; }"	
														;"\n:edit_box	{ key=" 	(chr 34) "E5" (chr 34) "; label = " (chr 34) " " (chr 34) "; edit_width=30; }"	
														;"\n:edit_box	{ key=" 	(chr 34) "E6" (chr 34) "; label = " (chr 34) " " (chr 34) "; edit_width=30; }"																
														;"\n:edit_box	{ key=" 	(chr 34) "E7" (chr 34) "; label = " (chr 34) " " (chr 34) "; edit_width=30; }"															
													"\n}"													

												"\n}"	
												"\n:boxed_row{"
														"\n:button			{ key=" (chr 34) "A" (chr 34) "; label = " (chr 34) (f (f_xm 6)) (chr 34) "; is_default = true; }"
														"\n:button			{ key=" (chr 34) "S" (chr 34) "; label = " (chr 34) (f (f_xm 8)) (chr 34) "; is_default = true; }"	
														"\n:button			{ key=" (chr 34) "O" (chr 34) "; label = " (chr 34) (f (f_xm 4)) (chr 34) "; is_default = true; }"												
														"\n:button			{ key=" (chr 34) "C" (chr 34) "; label = " (chr 34) (f (f_xm 3)) (chr 34) "; is_default = true; }"
														"\n:button			{ key=" (chr 34) "H" (chr 34) "; label = " (chr 34) (f (f_xm 5)) (chr 34) "; is_default = true; }"
														"\n:button			{ key=" (chr 34) "E" (chr 34) "; label = " (chr 34) (f (f_xm 7)) (chr 34) "; is_default = true; }"	
												"\n}"																
											"\n}"
										)						
									)
									(princ x1 x2)
									(close x2)
								)
								(alert (cadr (assoc '"de" (cdr (assoc '"e_lz" xm))))) 
							)
	(setq 		xp			(list "f_DCL_erstellen" '())
				r			"ok")
)
(defun		f_DCL_laden			; DCL_laden
				( / x1 x2)		
	(setq 		x1 				(load_dialog (cadr (assoc '"dcl" xs)))
				r				nil
	)
								(if (not (new_dialog "tool" x1))
									(alert (f (f_xm 2)))
									(progn
										(action_tile "A" "(f (f_DCL_Uebernehmen))(setq r t)(done_dialog 6)")
										(action_tile "O" "(f (f_var_xz_init))(f (f_DCL_A_Wert_init))")
										(action_tile "H" "(f (f_help))")
										(action_tile "C" "(f (f_DCL_A_Wert_init))")
										(action_tile "E" "(setq r nil)(done_dialog 6)")
										(action_tile "S" "(f (f_DCL_Uebernehmen))")
										
										(action_tile "B1" "(f_ordner)")										
											
										(foreach x1 (cadr (assoc '"EListe" xz))	
											(action_tile (strcat "S" (rtos x1 2)) "(f (f_help))")
										)
										(foreach x1 (cadr (assoc '"AListe" xz))	
											(action_tile (strcat "S-" (rtos x1 2)) "(f (f_help))")
										)										
											
										(f (f_DCL_Liste_def))
										(f (f_DCL_Auflisten))	
										(f (f_DCL_A_Wert_init))
										(f (f_DCL_Pruefen))
										
										(start_dialog)
										(unload_dialog x1)
									)
								)
	(setq 		xp				(list "f_DCL_laden" '())
				r				r
	)							
)
(defun 		f_DCL_Liste_def		; DCL-Listen definieren
				( / x1 x2 x3 x4 x5 x6)

								(setq x1 (tblnext "layer" "T"))
								(setq x2 '())
								(while (not (equal x1 nil))	(setq x2 (cons (cdr (assoc '2 x1)) x2))	(setq x1 (tblnext "layer")) )
								
								(setq x1 (tblnext "style" "T"))
								(setq x3 '("Standard"))
								(while (not (equal x1 nil))	(setq x3 (cons (cdr (assoc '2 x1)) x3))	(setq x1 (tblnext "style")) )	
								
								(setq x1 (tblnext "block" "T"))
								(if (equal x1 nil)
									(progn (setq x4 '("")))
									(progn
										(while (not (equal x1 nil))	(setq x4 (cons (cdr (assoc '2 x1)) x4))	(setq x1 (tblnext "block")) )	
									)
								)
								
								(setq x1 (tblnext "ucs" "T"))
								(if (equal x1 nil)
									(progn
										(setq x5 (list " "))
									)
									(progn 
										(while (not (equal x1 nil))	(setq x5 (cons (cdr (assoc '2 x1)) x5))	(setq x1 (tblnext "ucs")) )	
									)
								)
								(setq x1 (tblnext "view" "T"))
								(if (equal x1 nil)
									(progn (setq x6 '("")))
									(progn
										(while (not (equal x1 nil))	(setq x6 (cons (strcase (cdr (assoc '2 x1))) x6))	(setq x1 (tblnext "view")) )
										(setq x6 (vl-sort x6 '<))										
									)
								)								
	(setq 		xl 				(list 
									(list " ")
									(list "de")
									x4
									(list "ausgerichtet" "nicht ausgerichtet") 							
								)
	)
	(setq 		xp				(list "f_DCL_Liste_def" '())	
				r				"ok")	
)
(defun 		f_DCL_A_Wert_init	; DCL-Auswahlfeldlistenvorgabewert voreinstellen
				( / )							
								(foreach x1 (cadr (assoc '"EListe" xz))				 	
									(set_tile (strcat "E" (rtos x1 2)) 	(cadr (assoc (rtos x1 2) xz)))
								)
								(foreach x1 (cadr (assoc '"AListe" xz))				 	
									(set_tile (strcat "A" (rtos x1 2))
										(rtos (- (length (nth x1 xl))(length (member (cadr (assoc (strcat "-" (rtos x1 2)) xz))(nth x1 xl)))) 2))
								)
	(setq 		xp				(list "f_DCL_A_Wert_init" '())								
				r				"ok")							
)

(defun 		f_DCL_Auflisten		; DCL-Auflisten AlISTE
				( / )
									(foreach x1 (cadr (assoc '"AListe" xz)) 
										(start_list (strcat "A" (rtos x1 2)))
										(mapcar 'add_list (nth x1 xl))
										(end_list)
									)						
	(setq 		xp				(list "f_DCL_Auflisten" '())									
				r				"ok")	
)
(defun		f_DCL_Pruefen		; DCL-Pruefaufruf für Eingabefelder E1 ... Ex
				( / x1)			(if (> (length (cadr (assoc '"EListe" xz))) 0)
									(progn
										(foreach x1 (cadr (assoc '"EListe" xz))				 	
											(action_tile (strcat "E" (rtos x1 2)) 	
												(strcat "(f (f_DCL_Regeltest $value $reason " (rtos x1 2)  "))") 
											)
										)
									)
								)
	(setq 		xp				(list "f_DCL_Pruefen" '()))									
	(setq 		r				"ok")								
)
(defun 		f_DCL_Regeltest		; Regeltest
				( x1 			; E-Wert string value
				x2 x3 /
				x1 x2 x3 )		
								(cond	
									((and (member x3 '(1 2 3 ))(equal x1 ""))							; nicht leer
										(alert "Wert darf nicht leer sein!")
										(set_tile (strcat "E" (rtos x3 2)) (cadr (assoc (rtos x3 2) xz)))	
									)									
									((and (member x3 '(1 2 3 ))	(not (wcmatch x1 "~*[~-.0-9]*")))	; nur Dezimalzahlen
										(alert "Wert muss eine Dezimalzahl sein!")
										(set_tile (strcat "E" (rtos x3 2)) (cadr (assoc (rtos x3 2) xz)))	
									)	
									((and (member x3 '(1 2))	(= (atof x1) 0.0))					; <> 0
										(alert "Wert muss ungleich Null sein!")
										(set_tile (strcat "E" (rtos x3 2)) (cadr (assoc (rtos x3 2) xz)))	
									)										
									((and (member x3 '(1 2))	(not (> (atof x1) 0.0)))			; > 0
										(alert "Wert muss größer Null sein!")
										(set_tile (strcat "E" (rtos x3 2)) (cadr (assoc (rtos x3 2) xz)))	
									)	
									((and (member x3 '(3))	(not (>= (atof x1) 0.0)))						; >= 0
										(alert "Wert muss größer gleich Null sein!")
										(set_tile (strcat "E" (rtos x3 2)) (cadr (assoc (rtos x3 2) xz)))	
									)	
									((and (member x3 '(0))	(not (< (atof x1) 0.0)))						; < 0
										(alert "Wert muss kleiner Null sein!")
										(set_tile (strcat "E" (rtos x3 2)) (cadr (assoc (rtos x3 2) xz)))	
									)	
									((and (member x3 '(1))	(not (> (atof x1) 1.0)))				; > 1
										(alert "Wert muss größer Eins sein!")
										(set_tile (strcat "E" (rtos x3 2)) (cadr (assoc (rtos x3 2) xz)))	
									)	
									((and (member x3 '(0 ))	(not (>= (atof x1) 1.0)))				; >= 1
										(alert "Wert muss größer gleich Eins sein!")
										(set_tile (strcat "E" (rtos x3 2)) (cadr (assoc (rtos x3 2) xz)))	
									)										
									((and (member x3 '(0))	(not (and										; 0 <= ... <= 90
																		(<= (atof x1) 90)
																		(>= (atof x1) 0.0)
																	)))							
										(alert "Wert muss zwischen 0  und <= 90 liegen!")
										(set_tile (strcat "E" (rtos x3 2)) (cadr (assoc (rtos x3 2) xz)))	
									)
									((and (member x3 '(0 ))	(not (and										;  -360 ...  0
																		(>= (atof x1) -360)
																		(< (atof x1) 0.0)
																	)))							
										(alert "Wert muss zwischen >= -360 und 0 liegen!")
										(set_tile (strcat "E" (rtos x3 2)) (cadr (assoc (rtos x3 2) xz)))	
									)
									((and (member x3 '(0 ))	(not (and										;  360 ...  0
																		(<= (atof x1) -360)
																		(>(atof x1) 0.0)
																	)))							
										(alert "Wert muss zwischen >= 0 und <360 liegen!")
										(set_tile (strcat "E" (rtos x3 2)) (cadr (assoc (rtos x3 2) xz)))	
									)									
									
									((and (member x3 '(0 ))	(not (<= (atof x1) 360)))					; <= 360
										(alert "Wert muss <= 360 sein!")
										(set_tile (strcat "E" (rtos x3 2)) (cadr (assoc (rtos x3 2) xz)))	
									)	
									((and (member x3 '(1 ))	(not (wcmatch x1 "~*[~0-9]*")))			; nur ganze Zahlen
										(alert "Wert muss eine ganze Zahl sein!")
										(set_tile (strcat "E" (rtos x3 2)) (cadr (assoc (rtos x3 2) xz)))	
									)	
									((and (member x3 '(0))	(not (wcmatch x1 "~*[~>=]*")))			; nur bestimmte Zeichen
										(alert "Wert muss > oder >= sein!")
										(set_tile (strcat "E" (rtos x3 2)) (cadr (assoc (rtos x3 2) xz)))	
									)
											
								)
	(setq 		xp				(list "f_DCL_Regeltest" (list x1 x2 x3))								
				r				"ok")		
)
(defun		f_DCL_Uebernehmen	; DCL-Werte übernehmen/speichern
				( / )
								(foreach x1 (cadr (assoc '"EListe" xz))				 	
									(setq xz	
										(subst (list (rtos x1 2) (get_tile (strcat "E" (rtos x1 2))))(assoc (rtos x1 2) xz) xz)
									)
								)
								(foreach x1 (cadr (assoc '"AListe" xz))				 	
									(setq xz
										(subst 	
										(list (strcat "-" (rtos x1 2)) (nth (atoi (get_tile (strcat "A" (rtos x1 2)))) (nth x1 xl)))
										(assoc (strcat "-" (rtos x1 2)) xz) 
										xz )
									)
								)								
	(setq 		xp				(list "f_DCL_Uebernehmen" '())								
				r				xz)								
)

; ============================ 	  Sytem-Konfiguration
(defun		f_var_xs_init		; Systemeinstellung festlegen
				( / )
	(setq 		xp				(list "f_xvar_xs_init" '()))					
	(setq		xs				(list
									(list "dcl" (strcat (getvar "TEMPPREFIX") "tool.dcl"))
									(list "log" (strcat (getvar "TEMPPREFIX") "tool.log"))
									(list "help" (strcat (getvar "TEMPPREFIX") "help.html"))										
								)
	)
	(setq		r				xs )			
)
(defun 		f_xv_def			; AutoCAD-Umgebungsvariablen-Werte
				(  / )
	(setq 		xp				(list "f_xv_def" '()))				
	(setq 		xv 				(list
									'("CMDECHO" 0)	
									'("CMDDIA" 0)
									'("FILEDIA" 0)		
									'("OSMODE" 0)	
									'("OSNAPCOORD" 2)
									'("OSNAPOVERRIDE" 0)
									'("OSNAPZ" 0)										
									'("CLAYER" nil)	
									'("DYNMODE" 0)	
									'("COPYMODE" 1)		
									'("DELOBJ" 0)	
									'("INSUNITS" 6)	
									'("INSUNITSDEFSOURCE" 6)								
									'("INSUNITSDEFTARGET" 6)
									'("BLOCKEDITLOCK" 0)
									'("PEDITACCEPT" 1)
									'("AFLAGS" 4)	
									'("LAYERDLGMODE" 0)
									'("DIMTZIN" 8)
									'("DIMZIN" 8)
									'("CECOLOR" "vonlayer")	
									'("PLINETYPE" 2)
									'("HPASSOC" 1)	
									'("ANGBASE" 0.0)
									'("ANGDIR" 0)
									'("TILEMODE" 1)
									'("SMOOTHMESHCONVERT" 3)
									'("SURFACEMODELINGMODE" 0)
								)
	)
	(setq 		r				xv)	
)
; ============================ 	  Funktionen
(defun		f_help				; Helpfile erstellen
				( / x1)

								(alert (cadr (assoc (cadr (assoc "-1" xz)) xh)))
	(setq 		xp				(list "f_help" '())
				r				"ok")									
							
)
(defun		f_fw				; File schreiben
				( 	x1 			; Dateipfad+Dateiname
					x2 			; zu schreibender Inhalt
				/ 	x3 x4)
	(setq 		x3 				(open x1 "w"))	
								(if (not (equal x3 nil))
									(progn	(princ x2 x3)(close x3) (setq x4 "ok"))
									(progn (setq x4 (cadr (assoc (cadr (assoc "-1" xz)) (cdr (assoc "e_fw" xm))))))
								)
	(setq 		xp				(list "f_fw" (list x1 x2))								
				r				x4)							
)
(defun 		f_xv_sichern		; AutoCAD-Umgebungsvariablen sichern
				( / x1 x2)
	(setq 		xp				(list "f_xv_sichern" '()))				
								(setq x1 0 xv_alt '())
								(while (< x1 (length xv))
									(setq x2 (getvar (car (nth x1 xv))))
									(setq xv_alt (cons (list (car (nth x1 xv)) x2) xv_alt))
									(setq x1 (+ x1 1))
								)
	(setq 		xv_alt 			(reverse xv_alt))
	(setq		r				xv_alt )		
)
(defun 		f_xv_setzen			; AutoCAD-Umgebungsvariablen setzen
			( / x1 x2)
	(setq 		xp				(list "f_xv_setzen" '()))				
								(setq x1 0)
								(while (< x1 (length xv))
									(if (not (equal (cadr (nth x1 xv)) nil))
										(setq x2 (setvar (car (nth x1 xv))(cadr (nth x1 xv))))
									)
									(setq x1 (+ x1 1))
								)
	(setq		r				"ok")								
)
(defun 		f_xv_zuruecksetzen	; AutoCAD-Umgebungsvariablen zurücksetzen
			( / x1 x2)
	(setq 		xp				(list "f_xv_zuruecksetzen" '()))			
								(setq x1 0)
								(while (< x1 (length xv_alt))
									(if (not (equal (cadr (nth x1 xv_alt)) nil))
										(setq x2 (setvar (car (nth x1 xv_alt))(cadr (nth x1 xv_alt))))
									)
									(setq x1 (+ x1 1))
								)
	(setq		r				"ok")								
)
(defun		f_xm				; Mitteilungswert lesen
				(x1	/ x1)		; Kategorie	
			(setq 		xp				(list "f_xm" (list x1)))
			(setq		r				(cadr (assoc (cadr (assoc '"-1" xz)) (cdr (assoc x1 xm)))))						
)
(defun		f_test				; Testfunktion
				( / )
	(setq 		xp			(list "f_test" '()))	
	(setq		r			"Testresults")
)
(defun		f_var_def			; Variablen global 	definieren
				( / )
	(setq		r				nil			; Return
				xe				nil			; Error	
				xp				'()			; Funktionsparameter
				xs				'()			; Systemeinstellung
				xz				'()			; Systemzustand
				xm				'()			; Mitteilung
				xh				'()			; Help-HTML
				xf				'()			; Fehlerinhalt
				xv				'()			; AutoCAD-Variablenliste	
				xv_alt			'()			; AutoCAD-Variablenliste_vorherige Werte
				xl				'()			; DCL-Listenvariable				
	)
	(setq 		xp				(list "f_var_def" '()))
	(setq		r				"ok")	
)
(defun		f_var_undef			; Variablen global 	freigeben
				( / )
	(setq		r				nil			; Return
				xe				nil			; Error
				xp				nil			; Funktionsparameter
				xs				nil			; Systemeinstellung
				xz				nil			; Systemzustand
				xm				nil			; Mitteilung
				xh				'()			; Help-HTML
				xf				nil			; Fehlerinhalt	
				xv				nil			; AutoCAD-Variablenliste
				xv_alt			'()			; AutoCAD-Variablenliste_vorherige Werte		
				xl				'()			; DCL-Listenvariable				
	)
)
(defun		f					; Log-Aufruf
				( x1 / x1 )			
					
								(mapcar 'f_p 
									(list 	"\n" 
											(f_t) "-" (f_z) 
											"\t : Aktion : " (car xp)
											"\t : Result : " x1
											"\t : Parameter : " (cdr xp)
											"\n" 
									)
								)
	(setq 		r 				x1)
)
(defun		f_p					; Protokollieren
				(x1 / 
					x1 x2)
	(setq 		xp				(list "f_p" (list x1)))					
	(setq 		x2 				(open (cadr (assoc '"log" xs)) "a"))		
								(if (/= x2 nil)
									(progn
										(if (equal (cadr (assoc '"logtofile" xz)) "on")
											(princ x1 x2)
										)									
										(close x2)
									)
								)
								(if (equal (cadr (assoc '"logtoscreen" xz)) "on")
									(princ x1 )
								)
	(setq		r				"ok")
)
(defun 		f_t					; Datum ermitteln
				( / )	
			
	(setq 		r				(strcat		
									(substr (rtos (getvar "cdate")2 6) 1 4)			; Jahr
									(substr (rtos (getvar "cdate")2 6) 5 2)			; Monat
									(substr (rtos (getvar "cdate")2 6) 7 2)			; Tag
								)		
	)
)
(defun 		f_z					; Zeit ermitteln
				( / )			
	(setq		r				(strcat		
									(substr (rtos (getvar "cdate")2 6) 10 2)		; Stunden
									":"	(substr (rtos (getvar "cdate")2 6) 12 2)	; Minuten
									":"	(substr (rtos (getvar "cdate")2 6) 14 2)	; Sekunden
								)		
	)
)
(defun		f_str_do			; String ersetzen
		(p1 / p1	; 	(string suchmuster ersatzmuster modus (split | replace) )
			x1 
			x2		; String
			x3		; neuer String
			x4		; neue Liste
			z1
		)			
					(if (<= (strlen (nth 0 p1))(strlen (nth 1 p1)))
						(progn	(setq r "nok")
						)
						(progn
							(setq z1 1 x2 "" x3 "" x4 '() )
							(setq x1 (substr (nth 0 p1) z1 (strlen (nth 1 p1))))							
							(while (<= z1 (+ 1 (strlen (nth 0 p1))))
					
								(if (not (equal x1 (nth 1 p1)))
									(progn
										(setq x2 (strcat x2 (substr (nth 0 p1) z1 1)))
										(setq z1 (+ z1 1))
									)
									(progn		
										(setq x3 (strcat x3 x2))
										(setq x3 (strcat x3 (nth 2 p1)))		; ersetzen
										(setq x4 (cons x2 x4))					; liste
										(setq x2 "")
										(setq z1 (+ z1 (strlen (nth 1 p1))))
									)
								)
								(setq x1 (substr (nth 0 p1) z1 (strlen (nth 1 p1))))
							)
							(setq x3 (strcat x3 x2))
							(setq x4 (reverse (cons x2 x4)))
							(if (equal (nth 3 p1) "split")
								(setq r x4)
								(setq r x3)
							)
						)
					)
)
