;;;Bosse-engineering                                                                                       
;;;Dipl.-Ing. Jörn Bosse                                                                                   
;;;Am Klei 5                                                                                               
;;;38458 Velpke                                                                                            
;;;Tel. 05364 / 989 677                                                                                    
;;;mobil. 0176 / 282 323 51                                                                                
;;;bosse@bosse-engineering.com                                                                             
;;;                                                                                                        
;;;--------------------------------------------------------------------------------------------------------
;;;Funktion c:PON (PositionsNummern)						        	           
;;;													   
;;;Es werden an zu pickenden Positionen Nummern mit Kreise erzeugt, optional mit SOLID-Schraffur als       
;;;Hintergrund und Bezugslinie.										   
;;;													   
;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;;;globale Variablen:										   	   
;;;- JB_PON$DCL$_[x]_po (Positionen der Dialogfenster)							   
;;;                                                                              Jörn Bosse, 07.07.25      
;;;--------------------------------------------------------------------------------------------------------


;;;aufrufenden Funktionen
(defun c:PON ( / )
  (JB_PON)
  )


(defun c:PositionsNummern ( / )
  (JB_PON)
  )

;;;Definition der v_liste, wenn noch nicht vorhanden
(defun JB_PON:v_liste ( / )  
  '(
     ( "DboxSettings" . (
                         ( "Dbox1" .
                            (                             
                             ("JB_1_to1" . "1");;;Solid Hintergrund
			     ("JB_1_t1" . ((62 . 7 )(420 . nil)(430 . nil)));;;Farbe Hintergrund-SOLID
			     ("JB_1_t2" . ((62 . 7 )(420 . nil)(430 . nil)));;;Farbe Text
			     ("JB_1_e1" . 90);;;Transparenz 0 - 90
			     ("JB_1_to2" . "1");;;Bezugslinie
			     ("JB_1_t3" . ((62 . 7)(420 . nil)(430 . nil)));;;Farbe Kreis und Bezugslinie
			     ("JB_1_e2" . "2.5");;;Texthöhe
			     ("JB_1_p1" . ((0 . "STYLE") (100 . "AcDbSymbolTableRecord") (100 . "AcDbTextStyleTableRecord") (2 . "ARIAL") (70 . 0) (40 . 0.0) (41 . 1.0) (50 . 0.0) (71 . 0) (42 . 1.25) (3 . "arial.ttf") (4 . "")))
			     ("JB_1_e3" . 1);;;Startnummer
			     ("JB_1_e4" . "1.1");;;Vergrößerungsfaktor
			     )
			  )

                         )
      ))
  )

;;;Pfad für SIC-Datei in Windows-User
(defun JB_PON:pfad_ini ( / )
  (strcat (JBf_String:Userpfad:WinUser
                           "LispData\\acad\\"     ;;;Hier ändern, wenn anderer Pfad gewünscht, z.B. MeineTools\\Sicherungen\\ => Der LAufwerksbuchstabe c:\\ wird automatisch gegen das Windows-Benutzerverzeichnis 
                           )"PON_sic.lsp")  ;;;getauscht, z.B. c:\\User\\[WindowsUsername]\\LispData\\acad\\
  )

 

(defun JB_PON:Intro ( / )
  (princ "\nerstellt durch Bosse-engineering - www.bosse-engineering.com\n")
  (princ "\n---------------------PON(1.0), 07.07.25----------------------")
  (princ "\nPositionsNummern: Positionsnummern mit Kreisen.              ")
  (princ "\n-------------------------------------------------------------")
  )


;;;Hauptfunktion
(defun JB_PON ( / PFAD_INI V_LISTE Osmode_Alt)
  (vl-load-com)

  (setq pfad_ini (JB_PON:pfad_ini))

  ;;;ab AutoCAD 2014, setzen von vertrauenswürdigen Pfaden für Sicherungsdateien
  (if (JBf_AcadSystem:TrustedPaths?)
    (JBf_AcadSystem:TrustedPaths:Add (strcat(car(fnsplitl pfad_ini))"...")))

    (if (not(setq v_liste (if (findfile pfad_ini)
                          (load pfad_ini)nil)))
    (JBf_SIC:sichern
      (setq v_liste (JB_PON:v_liste))pfad_ini nil))
  
  
  (JBf_init
    '(("CMDECHO" 0)
      ("DIMZIN" 3)
      ))  
  
  (JB_PON:Intro)

  
  (if (not
            (or (and JB_PON_$DCL$_File(findfile JB_PON_$DCL$_File))
                (setq JB_PON_$DCL$_File (JB_PON:dcl:Write))))
        (progn
          (alert "Die DCL-Datei konnte nicht geschrieben werden.")
          (exit)))
  (JB_PON:Dbox1 v_liste pfad_ini)
      
   
  (princ "\nEnde.")

  (setq Osmode_Alt (getvar "OSMODE"))
  (JBf_Reinit)

  (setvar "OSMODE" Osmode_Alt)

  
  
  
  (princ)
  

)



(defun  JB_PON:v_liste:DboxSettings:get (key v_liste / )
  (cdr(assoc key(cdr (assoc "DboxSettings" v_liste))))
)


(defun JB_PON:v_liste:DboxSettings:put (key liste v_liste / DboxList) 
  (setq DboxList (cdr (assoc "DboxSettings" v_liste)))
  (setq DBoxList (JBf_list:subst:gc DBoxList liste key))
  (setq v_liste (JBf_list:subst:gc v_liste DBoxList "DboxSettings"))
  v_liste
  )

;;;Textstile
(defun JB_PON:Dbox1:p1Ini ( / )
  (vlax-for ITEM (vla-get-Textstyles(vla-get-activedocument(vlax-get-acad-object)))
    (setq p1&Dbox1 (cons (vla-get-name ITEM)p1&Dbox1)))

  (if (not(member (strcase (cdr(assoc 2 (cdr(assoc "JB_1_p1" Settings&Dbox1)))))(mapcar 'strcase p1&Dbox1)))
    (setq p1&Dbox1 (cons (cdr(assoc 2 (cdr(assoc "JB_1_p1" Settings&Dbox1))))p1&Dbox1)))

  (setq p1&Dbox1 (vl-sort p1&Dbox1 '(lambda(e1 e2)(< e1 e2))))
  (setq p1_sel&Dbox1 (- (length p1&Dbox1)
			(length(member (strcase (cdr(assoc 2 (cdr(assoc "JB_1_p1" Settings&Dbox1)))))(mapcar 'strcase p1&Dbox1)))))
  )

  
;;;Nummerliste für aktuellen Layer
(defun JB_PON:Dbox1:NummernList ( / AWS N  VLA-OBJ)
  (if (setq aws (ssget "_X"(list (cons 0 "TEXT")(cons 8 (getvar "CLAYER")))))
    (progn
      (setq n 0)
      (repeat (sslength aws)
	(if (car(cdr(assoc -3(entget (ssname aws n) '("JB_PON")))))
	  (progn
	    (setq vla-obj(vlax-ename->vla-object(ssname aws n)))
	    (setq NummernList&DBox1 (cons (cons(atoi(vla-get-TextString  vla-obj))vla-obj)NummernList&DBox1))
	    )
	  )
	(setq n (+ n 1))
	)
      )
    )
  (setq NummernList&DBox1 (vl-sort NummernList&DBox1 '(lambda(e1 e2)(> (car e1)(car e2)))))
  )
  


;;;DBox 1
(defun JB_PON:Dbox1(v_liste pfad_ini / A DCLID OK Settings&Dbox1 p1&Dbox1 p1_sel&Dbox1 error&Dbox1 NummernList&DBox1)

  (setq Settings&Dbox1 (JB_PON:v_liste:DboxSettings:get "Dbox1" v_liste))
  (JB_PON:Dbox1:NummernList)

  (JB_PON:Dbox1:p1Ini)
  
    
  (while  (not(member ok '(1 15 99)))

    (setq DclId(JBf_Dcl:Load_dialog JB_PON_$DCL$_File "PON_1" JB_PON$DCL$_1_po))
    
    (JB_PON:Dbox1:set)
    (JB_PON:Dbox1:mode)
           
    (mapcar '(lambda(A)(action_tile A (strcat "(JB_PON:Dbox1:action \""A"\")")))
      '("JB_1_to1" "JB_1_to2" 
	"JB_1_b1" "JB_1_b2" "JB_1_b3" "JB_1_b4" "JB_1_b5"
	"JB_1_p1"
        "accept" "cancel"))

    (setq ok (start_dialog))
    (unload_dialog DclId)

     

    (if (and (= ok 1)(<=(atof(cdr(assoc "JB_1_e2" Settings&dbox1)))0.0))
      (progn
	(setq ok -1)
	(setq error&Dbox1 "e2")
	(alert "Die Texthöhe muss größer Null sein."))
      )

    (if (and (= ok 1)(<=(atof(cdr(assoc "JB_1_e4" Settings&dbox1)))1.0))
      (progn
	(setq ok -1)
	(setq error&Dbox1 "e4")
	(alert "Der Vergrößerungsfaktor größergleich 1.0 sein."))
      )

    (if(and(= ok 1) (or (<(cdr(assoc "JB_1_e1" Settings&dbox1))0)
			(>(cdr(assoc "JB_1_e1" Settings&dbox1))90)))
      (progn
	(setq ok -1)
	(setq error&Dbox1 "e1")
	(alert "Der Transparenzwert für den SOLID-Hintergrund muss zwischen 0 und 90 liegen."))
      )

    )
    
   
    (cond((= ok 1)
	  (JB_PON:DBox1:Insert)
	  (setq v_liste (JB_PON:v_liste:DboxSettings:put "Dbox1" Settings&dbox1 v_liste))
	  (JBf_SIC:sichern v_liste pfad_ini nil)

	  )
	 ((= ok 15)
	  (JB_PON:DBox1:Move)
	  (setq v_liste (JB_PON:v_liste:DboxSettings:put "Dbox1" Settings&dbox1 v_liste))
	  (JBf_SIC:sichern v_liste pfad_ini nil)
	  )
	 ((= ok 99)	  
	  (setq v_liste (JB_PON:v_liste:DboxSettings:put "Dbox1" Settings&dbox1 v_liste))
	  (JBf_SIC:sichern v_liste pfad_ini nil)

	  )
	 )
  )



;;;Dbox 1 getten
(defun JB_PON:Dbox1:get ( / )
  (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 (atoi(get_tile "JB_1_e1"))"JB_1_e1"))
  (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 (vl-string-subst "." ","(get_tile "JB_1_e2"))"JB_1_e2"))
  (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 (atoi(get_tile "JB_1_e3"))"JB_1_e3"))
  (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 (vl-string-subst "." ","(get_tile "JB_1_e4"))"JB_1_e4"))
  )


;;;aus einem Textstilname die ENTMAKE-Liste zurückgeben

(defun JB_PON:Dbox1:action:StyleList( / )
  (setq Settings&dbox1(JBf_list:subst:gc Settings&dbox1
			(if (tblsearch "STYLE" (nth p1_sel&Dbox1 p1&Dbox1))
			  (vl-remove-if '(lambda(X)(or(member (car X)
							      '(-1 5 330 102))
						      (= (type (cdr X)) 'ENAME)))
			    (entget(tblobjname "STYLE" (nth p1_sel&Dbox1 p1&Dbox1))))
			  (cdr(assoc "JB_1_p1" Settings&dbox1))
			  )
			"JB_1_p1"))
  )
			

;;;Action (Variable global in Aufrufender Funktion)
(defun JB_PON:Dbox1:action (key / GCLIST)

  (cond 
	((= key "JB_1_to1")
	 (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 $value "JB_1_to1"))
	 (JB_PON:Dbox1:mode)
	 )
	((= key "JB_1_to2")
	 (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 $value "JB_1_to2"))
	 )	
	((= key "JB_1_p1")
	 (setq p1_sel&Dbox1 (atoi $value))
	 )
	((= key "JB_1_b1")
         (if (setq gcList(JB_PON:Dbox1:action:TrueColor:get (cdr(assoc "JB_1_t1" Settings&dbox1))))
	   (progn
	     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 gcList "JB_1_t1"))
	     (JB_PON:Dbox1:set)))
         )
	((= key "JB_1_b2")
         (if (setq gcList(JB_PON:Dbox1:action:TrueColor:get (cdr(assoc "JB_1_t2" Settings&dbox1))))
	   (progn
	     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 gcList "JB_1_t2"))
	     (JB_PON:Dbox1:set)))
         )
	((= key "JB_1_b3")
         (if (setq gcList(JB_PON:Dbox1:action:TrueColor:get (cdr(assoc "JB_1_t3" Settings&dbox1))))
	   (progn
	     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 gcList "JB_1_t3"))
	     (JB_PON:Dbox1:set)))
         )
	((= key "JB_1_b4")
	 (if NummernList&DBox1
	   (progn
	     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 (+(car(car NummernList&DBox1))1) "JB_1_e3"))
	     (set_tile "JB_1_e3" (itoa(cdr(assoc "JB_1_e3" Settings&dbox1))))
	     )
	   (alert (strcat "Es sind noch keine Nummerntexte auf dem aktuellen Layer \"" (getvar "CLAYER") "\" vorhanden."))
	   )
         )
	((= key "JB_1_b5")
	 (JB_PON:Dbox1:get)
	 (setq JB_PON$DCL$_1_po (done_dialog 15))	          
         )	
		
        ((= key "cancel");;;Ende
	 (JB_PON:Dbox1:action:StyleList)
	 (JB_PON:Dbox1:get)
         (setq JB_PON$DCL$_1_po (done_dialog 99))
         )
	((= key "accept");;;OK
	 (JB_PON:Dbox1:action:StyleList)
	 (JB_PON:Dbox1:get)
         (setq JB_PON$DCL$_1_po (done_dialog 1))
         )
        )

  
  )


(defun JB_PON:Dbox1:action:TrueColor:get (gcList / )
  (acad_truecolordlg (cond ((cdr(assoc 430 gcList))
			    (assoc 430 gcList))
			   ((cdr(assoc 420 gcList))
			    (assoc 420 gcList))
			   ('T (assoc 62 gcList)))nil)
  )

         
     
;;;Dbox1; Werte setzen 
(defun JB_PON:Dbox1:set ( / A)
  (mapcar '(lambda(A)
             (set_tile (strcat "JB_1_"(car A))(cadr A)))
    (list
      (list "to1" (cdr(assoc "JB_1_to1" Settings&dbox1)))
      (list "t1" (JBf_dbox_layer_set:farbe:string
		   (cdr(assoc 62(cdr(assoc "JB_1_t1" Settings&dbox1))))
		   (cdr(assoc 420(cdr(assoc "JB_1_t1" Settings&dbox1))))
		   (cdr(assoc 430(cdr(assoc "JB_1_t1" Settings&dbox1))))))
      (list "e1" (itoa(cdr(assoc "JB_1_e1" Settings&dbox1))))
      (list "to2" (cdr(assoc "JB_1_to2" Settings&dbox1)))
      (list "t2" (JBf_dbox_layer_set:farbe:string
		   (cdr(assoc 62(cdr(assoc "JB_1_t2" Settings&dbox1))))
		   (cdr(assoc 420(cdr(assoc "JB_1_t2" Settings&dbox1))))
		   (cdr(assoc 430(cdr(assoc "JB_1_t2" Settings&dbox1))))))
      (list "t3" (JBf_dbox_layer_set:farbe:string
		   (cdr(assoc 62(cdr(assoc "JB_1_t3" Settings&dbox1))))
		   (cdr(assoc 420(cdr(assoc "JB_1_t3" Settings&dbox1))))
		   (cdr(assoc 430(cdr(assoc "JB_1_t3" Settings&dbox1))))))
      (list "e2" (cdr(assoc "JB_1_e2" Settings&dbox1)))      
      (list "e3" (itoa(cdr(assoc "JB_1_e3" Settings&dbox1))))
      (list "e4" (cdr(assoc "JB_1_e4" Settings&dbox1)))
      ))

  (start_list "JB_1_p1" 3)
  (mapcar 'add_list p1&Dbox1)
  (end_list)
  (set_tile "JB_1_p1" (itoa p1_sel&Dbox1))
  )


;;;DBOX 1, moden
(defun JB_PON:Dbox1:mode ( / )
  (if (=(cdr(assoc "JB_1_to1" Settings&dbox1))"1")
    (progn
      (mode_tile "JB_1_b1" 0)
      (mode_tile "JB_1_t1" 0)
      (mode_tile "JB_1_e1" 0)      
      )
    (progn
      (mode_tile "JB_1_b1" 1)
      (mode_tile "JB_1_t1" 1)
      (mode_tile "JB_1_e1" 1)      
      )
    )

  (if error&Dbox1
    (mode_tile (strcat "JB_1_" error&Dbox1)2)
    (mode_tile "JB_1_e3" 2)
    )
  )
	


;;;aktuelle Nummer
(defun JB_PON:DBox1:Insert:NextN ( / RETN)
  (if (not (assoc (cdr(assoc "JB_1_e3" Settings&dbox1)) NummernList&DBox1))
    (setq RetN (cdr(assoc "JB_1_e3" Settings&dbox1)))

    (if (<=(cdr(assoc "JB_1_e3" Settings&dbox1))(car(car NummernList&DBox1)))
      (progn
	(setq RetN (+(car(car NummernList&DBox1))1))
	(alert (strcat "\nDie Nummer " (itoa(cdr(assoc "JB_1_e3" Settings&dbox1))) " war bereits vorhanden, es wurde die höchste Nummer +1 verwendet: " (itoa RetN)))
	)
    (setq RetN (cdr(assoc "JB_1_e3" Settings&dbox1)))
    )
    )
  RetN)
  


(defun JB_PON:DBox1:Insert ( / DO P RETN SPACE TEXTWERT VLA-OBJCIRCLE VLA-OBJHATCH VLA-OBJTEXT W XDATEN)
  (setq Do 'T)
  (setq w (angle (trans '(0 0 0)1 0)(trans '(1 0 0)1 0)))
  (setq space (JB_PON:CurrentSpace))

  (while Do

    (if (and(setq p (getpoint "\nBitte Punkt picken (ENTER=Ende):"))
	    (setq p (trans p 1 0)))
      (if(and (setq TextWert (itoa (JB_PON:DBox1:Insert:NextN)))
	      (setq vla-objText(JB_PON:Dbox1:Add:Text space TextWert p w))
	      (setq vla-objCircle (JB_PON:DBox1:Add:Circle space vla-objText w))
	      (setq vla-objHatch (JB_PON:DBox1:Add:Hatch space vla-objCircle vla-objText)))
	(progn
	  (JBf_list_xdaten_append "JB_PON" (vlax-vla-object->ename vla-objText)
	    (setq xdaten
		   (list
		     (cons 1005 (vla-get-handle vla-objCircle))
		     (cons 1005 (vla-get-handle vla-objHatch)))))

	  (if (and(=(cdr(assoc "JB_1_to2" Settings&dbox1))"1")
		  xdaten)
	    (JB_PON:DBox1:PosWithBzgLine nil xdaten vla-objText (cdr(assoc "JB_1_to2" Settings&dbox1)))
	    )

	  (setq NummernList&DBox1 (vl-sort(cons (cons (atoi TextWert) vla-objText)NummernList&DBox1)'(lambda(e1 e2)(>(car e1)(car e2)))))
	  (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 (+ (atoi TextWert) 1)"JB_1_e3"))
	  )
	)
      (setq Do nil)
      )
    )
  )


(defun JB_PON:DBox1:Move ( / AWS N SPACE VLA-OBJTEXT W XDATEN)
  
  (setq w (angle (trans '(0 0 0)1 0)(trans '(1 0 0)1 0)))
  (setq space (JB_PON:CurrentSpace))
  
  (if (and
	(princ (strcat "\nWählen Sie Nummerntexte auf dem aktuellen Layer \"" (getvar "CLAYER")))
	(setq aws (ssget (list (cons 0 "TEXT")(cons 8 (getvar "CLAYER"))))))
    (progn
      (setq n 0)
      (repeat (sslength aws)
	(if (and(setq xdaten(cdr(car(cdr(assoc -3(entget (ssname aws n) '("JB_PON")))))))
		(setq vla-objText (vlax-ename->vla-object (ssname aws n))))
	  (JB_PON:DBox1:PosWithBzgLine 'T xdaten vla-objText (cdr(assoc "JB_1_to2" Settings&dbox1)))
	  )
	(setq n (+ n 1))
	)
      )
    )
  )





;;;Text erzeugen
(defun JB_PON:Dbox1:Add:Text (space TextWert p w / GCLIST VLA-OBJ VLA-TRUECOLOR)

  (if(not(tblsearch "STYLE" (cdr(assoc 2(cdr(assoc "JB_1_p1" Settings&dbox1))))))
    (entmake(cdr(assoc "JB_1_p1" Settings&dbox1)))
    )
  

   (setq vla-obj(vla-addText
		  Space
		  TextWert
		  (vlax-3d-point p)
		  (atof(cdr(assoc "JB_1_e2" Settings&dbox1)))
		  ))
  (vla-put-rotation vla-obj w)
  (vla-put-layer vla-obj (getvar "CLAYER"))
  (vla-put-stylename vla-obj (cdr(assoc 2(cdr(assoc "JB_1_p1" Settings&dbox1)))))
  (vla-put-alignment vla-obj 10);;;Mitte-Zentrisch
  (vla-put-textalignmentpoint vla-obj (vlax-3D-point p))

  (vla-put-EntityTransparency vla-obj "0")

  (setq vla-TrueColor (vla-get-TrueColor vla-obj))
  (JB_TrueColor:putByGcList->TrueColorObj (cdr(assoc  "JB_1_t2" Settings&dbox1))vla-TrueColor)
  (vla-put-TrueColor vla-obj vla-TrueColor)
  (vla-put-ObliqueAngle vla-obj 0.0) 
  (vla-update vla-obj)
  
  vla-obj)

;;;Kreis erzeugen
(defun JB_PON:DBox1:Add:Circle (space vla-objText w / CIRCLEPARAM COORDS VLA-OBJ VLA-TRUECOLOR)
  (setq coords(JBf_TextBox:EckpunkteWelt (vlax-vla-object->ename vla-objText) (atof (cdr(assoc "JB_1_e4" Settings&dbox1)))))
  (setq coords(JBf_TextBox:EckpunkteWelt:MinMaxWelt coords w))
  (setq CircleParam(JBf_TextBox:EckpunkteWelt:GetKreisParam coords))
  (setq vla-obj (vla-addCircle Space (vlax-3D-point (cdr(assoc 10 CircleParam)))(cdr(assoc 40 CircleParam))))
  (vla-put-layer vla-obj (getvar "CLAYER"))
  (vla-put-EntityTransparency vla-obj "0")
  (setq vla-TrueColor (vla-get-TrueColor vla-obj))
  (JB_TrueColor:putByGcList->TrueColorObj (cdr(assoc  "JB_1_t3" Settings&dbox1))vla-TrueColor)
  (vla-put-TrueColor vla-obj vla-TrueColor)
  (vla-update vla-obj)
  vla-obj
  )





;;;Hatch erzeugen
(defun JB_PON:DBox1:Add:Hatch (space vla-objCircle vla-objText / VLA-OBJ VLA-TRUECOLOR)
  (setq vla-obj (vla-AddHatch space acHatchPatternTypePredefined "SOLID" :vlax-false))
  (vla-put-layer vla-obj (getvar "CLAYER"))
  (vla-put-EntityTransparency vla-obj (itoa(cdr(assoc "JB_1_e1" Settings&dbox1))))
  (vla-AppendOuterLoop vla-obj (vlax-safearray-fill(vlax-make-safearray vlax-vbObject '(0 . 0))(list vla-objCircle)))
  (JBf_CommandReplace:DraworderBelow-Above "unten" (vlax-vla-object->ename vla-obj)(vlax-vla-object->ename vla-objText))
  (setq vla-TrueColor (vla-get-TrueColor vla-obj))
  (JB_TrueColor:putByGcList->TrueColorObj (cdr(assoc  "JB_1_t1" Settings&dbox1))vla-TrueColor)
  (vla-put-TrueColor vla-obj vla-TrueColor)
  (vla-update vla-obj)
  vla-obj
  )


;;;Bezugslinien mit GRREAD
(defun JB_PON:DBox1:PosWithBzgLine (MoveFlag xdaten vla-objText BzgFlag / PCENTER PKTGR PSTART R VLA-OBJBZG VLA-OBJCIRCLE VLA-OBJHATCH X vla-TrueColor)
  (setq vla-objCircle(JB_PON:DBox1:PosWithBzgLine:Handle->vla-obj(cdr(car xdaten))))
  (setq vla-objHatch(JB_PON:DBox1:PosWithBzgLine:Handle->vla-obj(cdr(cadr xdaten))))
  (setq vla-objBzg (JB_PON:DBox1:PosWithBzgLine:Handle->vla-obj(cdr(caddr xdaten))))

  (if (and vla-objCircle vla-objHatch)
    (progn
      (setq r (vla-get-Radius vla-objCircle))
      (setq pCenter (trans(vlax-get  vla-objCircle 'Center)0 1))
      (if vla-objBzg
	(setq pStart (trans(vlax-get vla-objBzg 'StartPoint)0 1))
	(setq pStart pCenter))

      (princ "\nZweiter Punkt der Verschiebung: (Bezugslinie An/AUS: => <ENTER>)")

      (while (member(car (setq pktgr (grread 't 5 0)))'(5 12 2 25 11))
	(if (member(car pktgr)'(25 2));;;25 = rechtssklick, 2 = ENTER
	  (progn
	    (setq BzgFlag (itoa(- 1 (atoi BzgFlag))))
	    (redraw)
	    (if(= BzgFlag "1")
	      (grdraw pStart (polar pStart (angle pStart pCenter)(-(distance pStart pCenter)r)) 6)
	      )
	    )
	  (progn
	    
	    (mapcar '(lambda(X)(vla-move X (vlax-3D-point (trans pCenter 1 0))(vlax-3D-point(trans(cadr pktgr)1 0))))
		    (vl-remove-if 'not
		      (list vla-objCircle vla-objHatch vla-objText)))
	    (setq pCenter (cadr pktgr))
	    (redraw)
	    (if(= BzgFlag "1")
	      (grdraw pStart (polar pStart (angle pStart pCenter)(-(distance pStart pCenter)r)) 6)
	      )
	    )
	  )
	)
      (redraw)
      (if (= BzgFlag "1")
	(progn
	  (if vla-objBzg
	    (vla-delete vla-objBzg)
	    )
	  (entmake(list(cons 0 "LINE")(cons 8 (getvar "CLAYER"))(cons 10 (trans pStart 1 0))
					    (cons 11 (polar (trans pStart 1 0) (angle (trans pStart 1 0) (trans pCenter 1 0))(-(distance pStart pCenter)r)))
					    ))
	  (setq vla-objBzg (vlax-ename->vla-object(entlast)))
	  (JBf_list_xdaten_append "JB_PON" (vlax-vla-object->ename vla-objText)
	    (list
	      (cons 1005 (vla-get-handle vla-objCircle))
	      (cons 1005 (vla-get-handle vla-objHatch))
	      (cons 1005 (vla-get-handle vla-objBzg))))
	  (vla-put-EntityTransparency vla-objBzg "0")
	  (setq vla-TrueColor (vla-get-TrueColor vla-objBzg))
	  (JB_TrueColor:putByGcList->TrueColorObj (cdr(assoc  "JB_1_t3" Settings&dbox1))vla-TrueColor)
	  (vla-put-TrueColor vla-objBzg vla-TrueColor)
	  (vla-update vla-objBzg)

	  
	  )
	(progn
	  (if vla-objBzg
	    (vla-delete vla-objBzg)
	    )
	  (JBf_list_xdaten_append "JB_PON" (vlax-vla-object->ename vla-objText)
	    (list
	      (cons 1005 (vla-get-handle vla-objCircle))
	      (cons 1005 (vla-get-handle vla-objHatch))
	      )))
	)
      )
    (alert "Es fehlen der Kreis und/oder die Hintergrundfläche zur aktuellen Nummer.")
    )
  )


(defun JB_PON:DBox1:PosWithBzgLine:Handle->vla-obj (handle / )
  (if (and handle
	   (handent handle)
	   (entget (handent handle)))
    (vlax-ename->vla-object(handent handle)))
  )

  


   

;;;DCL-Datei schreiben
(defun JB_PON:Dcl:Write ( / A  FILE)
  (if(and(setq JB_PON_$DCL$_File(vl-filename-mktemp (strcat "PON.dcl")))
         (setq file (open JB_PON_$DCL$_File "w")))
    (progn
    (mapcar '(lambda(A)
               (write-line A file))
      (mapcar '(lambda(A)
                 (strcat "\n" A))
        '(
                "//Hauptdialog"
                "PON_1: dialog {label = \"Positionsnummern\";"
                ":boxed_column {label = \"Optionen\";"
                ":toggle {key = \"JB_1_to1\"; label = \"SOLID-Hintergrund\";}"
                ":row{"
                ":button {key = \"JB_1_b1\"; label = \"&Farbe...\";width = 35;}"
                ":text {key = \"JB_1_t1\"; label = \"R=1,G=2,B=3;\";width = 30;}"
                "}"
                ":edit_box {key = \"JB_1_e1\"; label = \"Transparenz (0 - 90)\";edit_width = 10;}"
	        ":row{"
	        ":button {key = \"JB_1_b2\"; label = \"F&arbe für Text...\";width = 35;}"
	        ":text {key = \"JB_1_t2\"; label = \"R=1,G=2,B=3;\";width = 30;}"
	        "}"
                ":toggle {key = \"JB_1_to2\"; label = \"Bezugslinie\";}"
                ":row{"
                ":button {key = \"JB_1_b3\"; label = \"F&arbe für Kreis und Bezugslinie...\";width = 35;}"
                ":text {key = \"JB_1_t3\"; label = \"R=1,G=2,B=3;\";width = 30;}"
                "}"
                ":edit_box {key = \"JB_1_e2\"; label = \"Texthöhe\";edit_width = 10;}"
                ":popup_list {key = \"JB_1_p1\"; label = \"Textstil\";}"
	        ":edit_box {key = \"JB_1_e4\"; label = \"Vergrößerungsfaktor für die Umrandung\";edit_width = 10;}"
                "}"
                ":boxed_column {label = \"Nummerierungsoptionen für aktuellen Layer\";"                
                ":edit_box {key = \"JB_1_e3\"; label = \"Startnummer\";edit_width = 10;allow_accept=true;}"
                ":button {key = \"JB_1_b4\"; label = \"&Höchste +1\";fixed_width = true; alignment = right;}"
                "}"
                ":row {fixed_width = true;alignment = centered;"
                ":button {label = \"&Einfügen\";  key= \"accept\";is_default=true;}"
                ":spacer {width = 2;}"
                ":button {key = \"JB_1_b5\"; label  = \"&Schieben\";}"
                ":spacer {width = 2;}"
                ":button {label = \"&Ende\";  key= \"cancel\";is_cancel=true;}"
                "}}"


          )))
    (close file)
    JB_PON_$DCL$_File)
    )
  )


;;;Aktueller Space für VLA-Kram
(defun JB_PON:CurrentSpace ( / )
  (if (or(= (strcase (getvar "CTAB")) "MODEL")
	   (/=(getvar "CVPORT")1))
      (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
      (vla-get-PaperSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
      )
  )



  
;;;--------------------------------------------------------------------------------------------------------
;;;allgemeine verwaltungstechnische Funktionen							   	   
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

;;;Fehlermeldung
;;;Fehlermeldung;;;
(defun JBf_Error  (s)
  (print (strcat "***Fehler*** " s))
  (JBf_Reinit))

;;;Initialisierungsfunktion
(defun JBf_init (InitVaris / )
  (setq	JB_Error *error*
        *error* JBf_Error)
  (vl-load-com)
  ;;;Systemvariablen aktuelle Einstellungen für ReInit speichern
  (setq JBf$ReInit$Varis
         (mapcar '(lambda(A)
                    (list (car A)(getvar (car A))))InitVaris))
  ;;;Vorgabeeistellungen für Systemvariablen
  (mapcar '(lambda(A)
             (if (cadr A)
               (setvar (car A)(cadr A))))InitVaris)
                   
                   
  )
;;;Reinitialisierung
(defun JBf_Reinit ( / n)
  ;;;Systemvariablen ReInitialisieren
  (mapcar '(lambda(A)
             (setvar (car A)(cadr A)))JBf$ReInit$Varis)
  (setq JBf$ReInit$Varis nil)
  (princ)
)
;;;--------------------------------------------------------------------------------------------------------
;;;allgemeine Funktionen => Strings								   	   
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


;;;benutzerspezifischer Pfad zum Speichern von Programmeinstellungen
(defun JBf_String:Userpfad:WinUser (UserPfad / )
  
  (setq UserList (JBf_String:Delimiter->List UserPfad "\\"))
  (setq Pfad (strcat "c:\\Users\\"(getvar "LOGINNAME")"\\"))
        

  ;;;wenn UserPfad noch nicht vorhanden, dann erstellen
  (mapcar '(lambda(A)
             (setq Pfad (strcat Pfad A "\\"))
             (if (not (JBf_String:FilePath? Pfad))
               (vl-mkdir Pfad)))
    UserList)
  Pfad
  )


;;;String anhand Trennzeichen in Liste zurückgeben
(defun JBf_String:Delimiter->List (Str Delim / StrList)
  (setq Str (vl-string-left-trim Delim Str)
	Str (vl-string-right-trim Delim Str))
  (if (vl-string-search Delim Str)
    (progn
      (while (vl-string-search Delim Str)
        (setq StrList (cons (substr Str 1 (vl-string-search Delim Str))StrList)
	      Str (vl-string-left-trim Delim(substr Str(+(vl-string-search Delim Str)(+ (strlen Delim)1))))))
      (if (/= Str "")
        (setq StrList (cons Str StrList))))
    (setq StrList (cons Str StrList)))
  (reverse StrList))

;;;Dateipfad prüfen
(defun JBf_String:FilePath? (Pfad / FSO TRUE-FALSE)
  (setq Pfad (if(vl-string-search "." Pfad)(car(fnsplitl  Pfad))Pfad))
  (if (setq FSO (vlax-create-object "Scripting.FilesystemObject"))
    (progn
      (if (vlax-method-applicable-p FSO 'FOLDEREXISTS)
        (setq TRUE-FALSE
               (=(vl-catch-all-apply
                   'vlax-invoke-method
                   (list FSO 'FOLDEREXISTS Pfad)):vlax-true))
        (vlax-release-object FSO))))
  TRUE-FALSE)



;;;--------------------------------------------------------------------------------------------------------
;;;allgemeine Funktionen => Listen								   	   
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

;;;Es wird der GcN-Eintrag gesubst
(defun JBf_list:subst:gc (liste Wert GcN / )
  (subst (cons GcN Wert)(assoc GcN liste)liste))


;;;Att_liste aus vla-object
(defun JBf_list_att_aus_block_vla-obj(vla-obj / A)
  (if (=(vla-get-hasattributes vla-obj):vlax-true)
    (mapcar '(lambda(A)(list(strcase(vlax-get A 'TagString))A))
      (vlax-safearray->list (vlax-variant-value(vla-getattributes vla-obj))))
  ))








;********************************************************************************************;;;
;;;JBf_xdaten_write  Es werden X-Daten an auszuwählendes Element angehängt                   ;;;
;;;******************************************************************************************;;;
;;;=> art "Name" als String
;;;=> obj
;;;=> Liste mit Dotted-Pair Elementen
(defun JBf_list_xdaten_append (art obj liste / )
   (regapp art)
  (entmod(append (entget obj)(list(list -3 (cons art liste))))))
;********************************************************************************************;;;
;;;JBf_xdaten_read  Es werden die XDaten eines Elementes zurückgegeben                         ;
;;;******************************************************************************************;;;
;;;=> art "Name" als String
;;;=> obj
;;;=> gc_nr wenn nil dann Rückgabe der ganzen Liste
(defun JBf_list_xdaten_read (art obj gc_nr / liste)
  (setq liste(cdr(assoc art(cdr(assoc -3(entget obj '("*")))))))
  (if gc_nr
    (cdr(assoc gc_nr liste))
    liste))



;;;--------------------------------------------------------------------------------------------------------
;;;alLGZmeine Funktionen => Listen in SIC-Datei sichern  					   	   
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

;;;Liste in LSP-Datei sichern
;;;Sichern von Einstellungen, Ausführung
;;;liste => DottetPairList, die es zu sichern gilt
;;;path => vollständiger Dateipfad mit Dateiname
;;;AcadTrustCheck => 'T or NIL, es wird bei 'T ein temnporärer TrustedPath erstellt und danach auch gleich wieder gelöscht
(defun JBf_SIC:sichern (liste FilePath AcadTrustCheck / FILESTREAM X)

  (setq FileStream (open FilePath "w"))
  (write-line "'(" FileStream)
  (mapcar '(lambda (X)
                   (JBf_SIC:sichern:prin1 X FileStream)
           )
          liste
  )
  (write-line ")" FileStream)
  (close FileStream)

  (if
    (if AcadTrustCheck
      (car (JBf_SIC:load:Catch FilePath nil))
      (vl-catch-all-error-p
        (vl-catch-all-apply 'JBf_SIC:load (list FilePath))
      )
    )


    (if (findfile (strcat (car (fnsplitl FilePath)) (cadr (fnsplitl FilePath)) ".bak"))
      (progn
        (alert (strcat "Die Sicherungsdatei \n\n"
                       FilePath
                       "\n\n ist fehlerhaft und wird automatisch durch die BAK-Datei\n\n"
                       (strcat (car (fnsplitl FilePath)) (cadr (fnsplitl FilePath)) ".bak")
                       "\n\nersetzt."
               )
        )
        (if (vl-file-delete FilePath)
          (vl-file-copy (strcat (car (fnsplitl FilePath)) (cadr (fnsplitl FilePath)) ".bak") FilePath)
          (alert (strcat "Die Sicherungsdatei \n\n"
                         FilePath
                         "\n\n ist fehlerhaft und konnte nicht automatisch durch die BAK-Datei\n\n"
                         (strcat (car (fnsplitl FilePath)) (cadr (fnsplitl FilePath)) ".bak")
                         "\n\nersetzt werden. Bitte führen Sie diesen Arbeitsgang manuell durch."
                 )
          )
        )
      )

      (alert (strcat "Die Sicherungsdatei \n\n"
                     FilePath
                     "\n\n ist fehlerhaft, bitte löschen Sie diese, anderfalls kann das Programm nicht mehr\n"
                     "ordnungsgemäß starten."
             )
      )
    )
    (if (findfile (strcat (car (fnsplitl FilePath)) (cadr (fnsplitl FilePath)) ".bak"))
      (if (vl-file-delete (strcat (car (fnsplitl FilePath)) (cadr (fnsplitl FilePath)) ".bak"))
        (vl-file-copy FilePath (strcat (car (fnsplitl FilePath)) (cadr (fnsplitl FilePath)) ".bak"))
        (alert (strcat "Für die Sicherungsdatei \n\n"
                       FilePath
                       "\n\n konnte keine BAK-Datei erstellt werden. Bitte löschen Sie die vorh. BAK-Datei\n\n"
                       (strcat (car (fnsplitl FilePath)) (cadr (fnsplitl FilePath)) ".bak")
                       "\n\nmanuell."
               )
        )
      )
      (vl-file-copy FilePath (strcat (car (fnsplitl FilePath)) (cadr (fnsplitl FilePath)) ".bak"))
    )
  )
)
;;;Laden der Datei um zu prüfen, ob diese korrekt ist!
  (defun JBf_SIC:load (FilePath /)
    (load FilePath)
  )
;;;Pfad muss existieren, Prüfung in aufrufender Funktion und temporärem TrustPath
  (defun JBf_SIC:load:Catch (PathFile ErrMsg / ERROR RETVAL TRUTHPATHSET)
    (if (JBf_AcadSystem:TrustedPaths?)
      (progn
        (setq TruthPathSet 'T)
        (JBf_AcadSystem:TrustedPaths:Add (strcat (car (fnsplitl PathFile)) "..."))
      )
    )

    (setq error (vl-catch-all-error-p
                  (setq RetVal (vl-catch-all-apply 'JBf_SIC:load (list PathFile)))
                )
    )
    (if (and error ErrMsg)
      (alert ErrMsg)
    )

    (if TruthPathSet
      (JBf_AcadSystem:TrustedPaths:Delete (strcat (car (fnsplitl PathFile)) "..."))
    )
    (list error RetVal)
  )
;;;Iteratives lustiges Listenschreiben
  (defun JBf_SIC:sichern:prin1 (A FileStream / B)

    (cond  ;;;wenn einzelner Eintrag
                 ((atom A)
                        (write-line (vl-prin1-to-string A) FileStream)
                 )
      ((and (atom (car A)) (not (cdr A)))  ;;;GC ohne Wert
            (write-line (vl-prin1-to-string A) FileStream)
      )
      ((and (atom (car A)) (cdr A) (not (listp (cdr A))))  ;;;DottedPair
            (write-line (vl-prin1-to-string A) FileStream)
      )
      ((and (atom (car A)) (cdr A) (listp (cdr A)) (= (length (cdr A)) 1) (atom (car (cdr A))))  ;;;GC + Wert
            (write-line (strcat "(" (vl-prin1-to-string (car A))) FileStream)
            (mapcar '(lambda (B)
                             (JBf_SIC:sichern:prin1 B FileStream)
                     )
                    (cdr A)
            )
         (write-line ")" FileStream)
      )
      ((and (atom (car A)) (cdr A) (listp (cdr A)))  ;;;GC + Liste
            (write-line (strcat "(" (vl-prin1-to-string (car A))) FileStream)
            (mapcar '(lambda (B)
                             (JBf_SIC:sichern:prin1 B FileStream)
                     )
                    (cdr A)
            )
         (write-line ")" FileStream)
      )
      ( 'T
        (write-line "(" FileStream)
        (mapcar '(lambda (B)
                         (JBf_SIC:sichern:prin1 B FileStream)
                 )
                A
        )
         (write-line ")" FileStream)
      )
    )
  )  



;;;--------------------------------------------------------------------------------------------------------
;;;Setzen von "TrustedPaths's" ab ACAD  2014								   
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

;;;Prüfen, ob bereits TrustedPaths in der aktuelle Version verwendet werden können
(defun JBf_AcadSystem:TrustedPaths? ( / )
  (and (= "ACAD" (strcase (getvar "PROGRAM"))) (getvar "SECURELOAD"))
  )

;;;Pfadangaben immer mit BackSlashes, "\\..." hinten angestellt, damit alle untergeordneten Verzeichnisse berücksichtigt werden
(defun JBf_AcadSystem:TrustedPaths:Add (pfad / TRUSTEDPATHS)
  (setq TrustedPaths(if (getvar "TRUSTEDPATHS")(getvar "TRUSTEDPATHS")""))
  (if(not(member (strcase pfad)(mapcar 'strcase (JBf_AcadSystem:TrustedPath:Split TrustedPaths))))
    (setvar "TRUSTEDPATHS"(strcat TrustedPaths ";" pfad)))
  )

;;;Pfad entfernen
(defun JBf_AcadSystem:TrustedPaths:Delete (pfad / A TRUSTEDPATHS)
  (setq TrustedPaths(if (getvar "TRUSTEDPATHS")(getvar "TRUSTEDPATHS")""))
  (setvar "TRUSTEDPATHS"
	  (vl-string-right-trim ";"(apply 'strcat(mapcar '(lambda(A)
							   (strcat A ";"))
							(vl-remove-if 'not (mapcar '(lambda(A)
										      (if(/= (strcase pfad)(strcase A))A))
										   (JBf_AcadSystem:TrustedPath:Split TrustedPaths)))))))
  )
			     

;;;String splitten an Semikolons, als Liste zurückgeben
(defun JBf_AcadSystem:TrustedPath:Split (TrustedPaths / A RETLIST TEMP)
  (mapcar '(lambda(A)
	     (if (/= A 59)
	       (setq temp (cons A temp))
	       (setq RetList (cons (vl-list->string(reverse temp))RetList)
		     temp nil))
	     )
	     (vl-string->list TrustedPaths))
  (if temp
    (setq RetList (cons (vl-list->string (reverse temp))RetList)))
  (reverse RetList))

;;;--------------------------------------------------------------------------------------------------------
;;;allgemeine Funktionen => Dcl									   	   
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~



;;;DCL-Dialogfenster laden
(defun JBf_Dcl:Load_dialog (FileName DialogName JB_$DCL$_x_po / DclId)
  (setq DclId (load_dialog FileName))
  (if	JB_$DCL$_x_po
    (if (not (new_dialog DialogName DclId "" JB_$DCL$_x_po))
      (exit))
    (if (not (new_dialog DialogName DclId))
      (exit)))
  DclId
  )


;;;--------------------------------------------------------------------------------------------------------
;;;allgemeine Funktionen => TrueColor								   	   
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


;;;String für Farbanschrieb, ACI, RGB oder Farbbuch
(defun JBf_dbox_layer_set:farbe:string (aci RGB Farbbuch / )
 (cond (Farbbuch
	  Farbbuch)
       (RGB
	  (setq TrueColor (JBf_TrueColor:gcList->vlaList (vl-remove-if 'not(list (cons 62 ACI)(if RGB (cons 420 RGB))(if Farbbuch (cons 430 Farbbuch))))))	  
	  (strcat "R="(itoa(cdr(assoc "Red" truecolor)))
		  " G="(itoa(cdr(assoc "Green" truecolor)))
		  " B="(itoa(cdr(assoc "Blue" truecolor)))))
       ('T (JBf_layer:Aci:Get:Name1 (abs aci)))))

(defun JBf_layer:Aci:Get:Name1(farbnr / name)
  (cond ((= farbnr 1)"Rot")
	((= farbnr 2)"Gelb")
	((= farbnr 3)"Grün")
	((= farbnr 4)"Cyan")
	((= farbnr 5)"Blau")
	((= farbnr 6)"Magenta")
	((= farbnr 7)"Weiß")
	((= farbnr 256)"VonLayer")
	((= farbnr 0)"VonBlock")
	('T (itoa farbnr))))
;;;##### GcList -> vlaList
(defun JBf_TrueColor:gcList->vlaList (gcList / GC420 GC430 GC62 RETLIST RGB)
  (setq gc62 (cdr(assoc 62 gcList))
	gc420 (cdr(assoc 420 gcList))
	gc430 (cdr(assoc 430 gcList))
	RetList (JBf_TrueColor:vlaList:Ini))
		  
  (if (and gc430 (vl-string-search "$" gc430))
    (setq RetList (JBf_list:subst:gc RetList (substr gc430 1 (vl-string-search "$" gc430))"BookName")
	  RetList (JBf_list:subst:gc RetList (substr gc430 (+ 2(vl-string-search "$" gc430)))"ColorName")))

  (cond ((= gc62 0);;;ByBlock
	 (setq RetList(JBf_list:subst:gc RetList 193 "ColorMethod")
	       RetList(JBf_list:subst:gc RetList 0 "Red")
	       RetList(JBf_list:subst:gc RetList 0 "Green")
	       RetList(JBf_list:subst:gc RetList 0 "Blue")
	       RetList(JBf_list:subst:gc RetList 0 "ColorIndex")))

	((= gc62 256);;;ByLayer
	 (setq RetList(JBf_list:subst:gc RetList 192 "ColorMethod")
	       RetList(JBf_list:subst:gc RetList 0 "Red")
	       RetList(JBf_list:subst:gc RetList 0 "Green")
	       RetList(JBf_list:subst:gc RetList 0 "Blue")
	       RetList(JBf_list:subst:gc RetList 256 "ColorIndex")))

	('T ;;;ACI
	 (setq RetList(JBf_list:subst:gc RetList 195 "ColorMethod")
	       RGB(JBf_TrueColor:gcList->vlaList:aci->rgb gc62)
	       RetList(JBf_list:subst:gc RetList (car RGB) "Red")
	       RetList(JBf_list:subst:gc RetList (cadr RGB) "Green")
	       RetList(JBf_list:subst:gc RetList (caddr RGB) "Blue")
	       RetList(JBf_list:subst:gc RetList gc62 "ColorIndex"))
	 ))
  (setq RetList (JBf_list:subst:gc RetList (+ (lsh (boole 9 (cdr(assoc "ColorMethod" RetList)) 255) 24) (fix (cdr(assoc "ColorIndex" RetList))))"EntityColor"))

  (if gc420
    (setq RetList(JBf_list:subst:gc RetList 194 "ColorMethod")
	  RGB(JBf_TrueColor:gcList->vlaList:aci->rgb gc62)
	  RetList(JBf_list:subst:gc RetList (lsh (fix gc420) -16) "Red")
	  RetList(JBf_list:subst:gc RetList (lsh (lsh (fix gc420) 16) -24) "Green")
	  RetList(JBf_list:subst:gc RetList (lsh (lsh (fix gc420) 24) -24) "Blue")
	  RetList(JBf_list:subst:gc RetList (+ (lsh (boole 9 (cdr(assoc "ColorMethod" RetList)) 255) 24)
					       (lsh (fix (cdr(assoc "Red" RetList))) 16)
					       (lsh (fix (cdr(assoc "Green" RetList))) 8)
					       (fix (cdr(assoc "Blue" RetList)))) "EntityColor")))
  RetList)
;;;Ini-VlaList
(defun JBf_TrueColor:vlaList:Ini ( / )
  '(("Blue" . nil)
    ("BookName" . nil)
    ("ColorIndex" . nil)
    ("ColorMethod" . nil)
    ("ColorName" . nil)
    ("EntityColor" . nil)
    ("Green" . nil)
    ("Red" . nil)))


;;;aci Farbnummer in RGB-Werte
(defun JBf_TrueColor:gcList->vlaList:aci->rgb  (n / l1 l3)
  (cond
    ((or (> n 255) (< n 1)) nil)
    ((> 7 n 0) (JBf_TrueColor:gcList->vlaList:aci->rgb (+ 10 (* 40 (1- n)))))
    ((> 250 n 9)
     (setq l1 '(0 1 2 3 4 4 4 4 4 4 4 4 4 3 2 1 0 0 0 0 0 0 0 0))
     (setq l3 '(1 0.8 0.6 0.5 0.3))
     (mapcar '(lambda (v w /)
		(fix (*	255
			(+ (* 0.25
			      (nth (rem (+ (1- (/ n 10)) v) 24) l1)
			      (nth (/ (rem n 10) 2) l3))
			   (* (rem n 2)
			      0.125
			      (nth (rem (+ (1- (/ n 10)) w) 24) l1)
			      (nth (/ (rem n 10) 2) l3))))))
	     '(8 0 16)
	     '(20 12 4)))
    (1
     (apply '(lambda (v w /) (list w w w))
	    (assoc n
		   '((7 255)
		     (8 128)
		     (9 192)
		     (250 51)
		     (251 91)
		     (252 132)
		     (253 173)
		     (254 214)
		     (255 255)))))))



;;;TrueColor aus GcList auf TrueColor-Objekt anbringen
(defun JB_TrueColor:putByGcList->TrueColorObj (gcList vla-TrueColor / VLALIST)
  (setq vlaList (JBf_TrueColor:gcList->vlaList gcList))
  ;(vla-put-ColorMethod vla-TrueColor (cdr(assoc "ColorMethod" vlaList))) => wegen ACAD 2021 abgeschaltet
  (if(=(cdr(assoc "ColorMethod" vlaList))194);;;RGB-Farbbuch
    (if (and (cdr(assoc "BookName" vlaList))
	     (cdr(assoc "ColorName" vlaList)))
      (vla-SetColorBookColor vla-TrueColor (cdr(assoc "BookName" vlaList))(cdr(assoc "ColorName" vlaList)))
      (vla-SetRgb vla-TrueColor (cdr(assoc "Red" vlaList))(cdr(assoc "Green" vlaList))(cdr(assoc "Blue" vlaList)))
      )
    (vla-put-ColorIndex vla-TrueColor (cdr(assoc "ColorIndex" vlaList)))
    )
  )


;;;--------------------------------------------------------------------------------------------------------
;;;allgemeine Funktionen => TextBox (sind auch Math-Funktionen mit dabei zur Berechung von MinMax-Koords)  
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;;;Allgemeine Textbox-Funktionen
;;;Rückgabe der Welt-Rahmen-Koordinaten eines Textes/Attributes
;;;Verbessung der Rahmenausdehnung 30% der Gesamtdiagonalen zu jeder Seite
(defun JBf_TextBox:EckpunkteWelt (Txtobj AusdehungsFaktor / A BASIS P1 P2 P3 P4 TBKOORD WINKEL)
  
  (setq tbKoord (textbox (entget Txtobj))
        basis (cdr(assoc 10 (entget Txtobj)))
        winkel (cdr(assoc 50 (entget Txtobj)))
        p1 (polar '(0.0 0.0) (+ (angle '(0.0 0.0)(car tbKoord))winkel)(distance '(0.0 0.0) (car tbKoord)))
        p2 (polar p1 winkel (- (car(cadr tbKoord))(car(car tbKoord))))
        p3 (polar p2 (+ winkel (* pi 0.5))(- (cadr(cadr tbKoord))(cadr(car tbKoord))))
        p4 (polar p3 (+ winkel pi)(- (car(cadr tbKoord))(car(car tbKoord)))))
  (mapcar '(lambda(A)(mapcar '+ basis A))
    (list (polar p2 (angle p2 p1)(*(distance p2 p1)AusdehungsFaktor))
          (polar p4 (angle p4 p2)(*(distance p4 p2)AusdehungsFaktor))
          (polar p1 (angle p1 p2)(*(distance p1 p2)AusdehungsFaktor))
          (polar p2 (angle p2 p4)(*(distance p2 p4)AusdehungsFaktor)))
    )
  )

;;;Aus Rechteck die Kreisparameter Mittelpunkt und Radius wiedergeben
(defun JBf_TextBox:EckpunkteWelt:GetKreisParam (KoordList / )
  (list (cons 10 (polar (car KoordList)(angle (car KoordList)(caddr KoordList))(/(distance (car KoordList)(caddr KoordList))2.0)))
        (cons 40 (/(distance (car KoordList)(caddr KoordList))2.0))))


;;;Aus Kreise und Mittelpunkt SegmentKoordListe des Kreise wiedergeben (24 Segmente)
(defun JBf_TextBox:Eckunkte:GetKreisSegmentKoords (Zentrum Radius / LISTE PISEKTOR PIWERT)
  (setq piSektor (/(* 2.0 pi)24.0)
        piWert 0.0)
  (repeat 24
    (setq liste (cons(polar Zentrum piWert Radius)liste)
	  piWert (+ piWert piSektor)))
  (reverse liste))


;;;es werden aus einer WeltKoordList bezogen auf einen WeltWinkel die Rechteckkoordinaten in Welt für die Maximale Ausdehnung zurückgegeben

(defun JBf_TextBox:EckpunkteWelt:MinMaxWelt (KoordList winkel / )
  (setq PP_list (list (list'(0.0 0.0)'(0.0 0.0))
                      (list'(10000.0 0.0)(polar '(0.0 0.0) winkel 10000.0))
                      (list'(0.0 10000.0)(polar '(0.0 0.0)(+ winkel (* 0.5 pi)) 10000.0))
                      )
        HelmertParam (JBf_math:helmert:param PP_List))


  (setq koordList
         (mapcar '(lambda(A)
                    (list (JBf_math:helmert:trans:Pkt HelmertParam A) A))koordList))

  (setq xMin (car(car(car(vl-sort koordList '(lambda(e1 e2)(< (car(car e1))(car(car e2))))))))
        xMax (car(car(car(vl-sort koordList '(lambda(e1 e2)(> (car(car e1))(car(car e2))))))))
        yMin (cadr(car(car(vl-sort koordList '(lambda(e1 e2)(< (cadr(car e1))(cadr(car e2))))))))
        yMax (cadr(car(car(vl-sort koordList '(lambda(e1 e2)(> (cadr(car e1))(cadr(car e2)))))))))


  (setq PP_list (mapcar 'reverse PP_list)
        HelmertParam (JBf_math:helmert:param PP_List))

  (list (JBf_math:helmert:trans:Pkt HelmertParam (list xMin yMin))
        (JBf_math:helmert:trans:Pkt HelmertParam (list xMax yMin))
        (JBf_math:helmert:trans:Pkt HelmertParam (list xMax yMax))
        (JBf_math:helmert:trans:Pkt HelmertParam (list xMin yMax)))
  )


;;;******************************************************************************************;;;
;;;JBf_math:helmert:param Helmerttransformation Bestimmung der Parameter		     ;;;
;;;******************************************************************************************;;;
;;;PP_List: ((p1neu p1alt)(p2neu p2alt)...)
;;;Vermessungssystem: y = Rechtswert (x)
;;;                   x = Hochwert (y)
(defun JBf_math:helmert:param (PP_List / A M O WINKEL X X0 XS_ALT XS_NEU Y0 YS_ALT YS_NEU)
  (if (>(length PP_List)2);;;Es wird erst ab 3 Punkten transformiert
    (progn
      ;;;Schwerpunktskoordinaten
      (setq ys_alt (/(apply '+ (mapcar 'car(mapcar 'cadr PP_List)))(length PP_List))
            xs_alt (/(apply '+ (mapcar 'cadr(mapcar 'cadr PP_List)))(length PP_List))
            YS_NEU (/(apply '+ (mapcar 'car(mapcar 'car PP_List)))(length PP_List))
            XS_NEU (/(apply '+ (mapcar 'cadr(mapcar 'car PP_List)))(length PP_List)))

      ;;;Reduktion auf den Schwerpunkt in Liste PP_List anhängen (pos 2)
      (setq PP_List (mapcar '(lambda(X)
                               (append X
                                 (list
                                   (list (-(car(cadr X))ys_alt)
                                         (-(cadr(cadr X))xs_alt)
                                         (-(car(car X))YS_NEU)
                                         (-(cadr(car X))XS_NEU)))))PP_List))
      ;;;Transformationsparameter
      (setq o (JBf_math:helmert:param:o PP_List)
            a (JBf_math:helmert:param:a PP_List)
            Y0 (-(- YS_NEU (* a ys_alt))(* o xs_alt))
            X0 (+(- XS_NEU (* a xs_alt))(* o ys_alt))
            ;;;Maßstabsfaktor
            m (sqrt(+(* a a)(* o o))))
      (if (= a 0.0)(alert "Fehler bei Helmert-Transformation, bitte prüfen."))
      (setq winkel (JBf_math:helmert:param:winkel o a))
  (list (cons "Y0" Y0)
        (cons "X0" X0)
        (cons "o" o)
        (cons "a" a)
        (cons "w" winkel)
        (cons "m" m)))
  )
  )

;;;Helmerttreansformation => o
(defun JBf_math:helmert:param:o (PP_List / )
  (/
    (apply '+(mapcar '(lambda(X)(-(* (cadr(caddr X))
                                     (caddr(caddr X)))
                                  (* (car(caddr X))
                                     (cadddr(caddr X)))))PP_List))
    (apply '+(mapcar '(lambda(X)(+(* (cadr(caddr X))
                                     (cadr(caddr X)))
                                  (* (car(caddr X))
                                     (car(caddr X)))))PP_List)))
  )
;;;Helmerttreansformation => a
(defun JBf_math:helmert:param:a (PP_List / )
  (/
    (apply '+(mapcar '(lambda(X)(+(* (cadr(caddr X))
                                     (cadddr(caddr X)))
                                  (* (car(caddr X))
                                     (caddr(caddr X)))))PP_List))
    (apply '+(mapcar '(lambda(X)(+(* (cadr(caddr X))
                                     (cadr(caddr X)))
                                  (* (car(caddr X))
                                     (car(caddr X)))))PP_List))))

;;;Helmerttransformation => winkel
(defun JBf_math:helmert:param:winkel (o a / )
  (cond ((and(>= a 0.0)
             (>= o 0.0))
         (atan(/ o a)))
        ((and(< a 0.0)
             (>= o 0.0))
         (+ (atan(/ o a)) pi))
        ((and(< a 0.0)
             (< o 0.0))
         (+ (atan(/ o a)) pi))
        ((and(>= a 0.0)
             (< o 0.0))
         (+ (atan(/ o a)) (* pi 2.0)))))

;;;Helmerttransformation => Einzelnen Punkt transformieren
(defun JBf_math:helmert:trans:Pkt (HelmertParam pkt / )
  (list (+(+(cdr(assoc "Y0" HelmertParam))
            (* (cdr(assoc "a" HelmertParam))(car pkt)))
          (* (cdr(assoc "o" HelmertParam))(cadr pkt)))
        (-(+(cdr(assoc "X0" HelmertParam))
            (* (cdr(assoc "a" HelmertParam))(cadr pkt)))
          (* (cdr(assoc "o" HelmertParam))(car pkt)))
        (if (caddr pkt)(caddr pkt)0.0)))



;;;--------------------------------------------------------------------------------------------------------
;;;allgemeine Funktionen => vla									   	   
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


;;;SortTable, wenn vorhanden, sonst catchen
(defun JBf_CommandReplace:DraworderBottom:SortTbl (Space / )
  (if(not(zerop(vla-get-count (vla-getExtensionDictionary Space))))
    (vla-GetObject (vla-getExtensionDictionary Space) "ACAD_SORTENTS")
    (vla-AddObject (vla-getExtensionDictionary Space) "ACAD_SORTENTS" "ACDBSORTENTSTABLE")
    ))

;;;Draworder, aktuelles Objekt über oder unter Referenzobjekt
;;;Flag: "unten" oder "oben"
(defun JBf_CommandReplace:DraworderBelow-Above(Flag obj objRef / ENT ENTARRAY LASTENT SORTTBL SPACE)
  (if (or(= (strcase (getvar "CTAB")) "MODEL")
         (/=(getvar "CVPORT")1))
    (setq Space (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
    (setq Space (vla-get-PaperSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
    )

  (if(not (vl-catch-all-error-p
            (setq SortTbl(vl-catch-all-apply
                           'JBf_CommandReplace:DraworderBottom:SortTbl (list Space)))))
    (progn
      
      (setq EntArray (vlax-make-safearray vlax-vbObject '(0 . 0)))
      (vlax-safearray-put-element EntArray 0 (vlax-ename->vla-object obj))
      
      (if (= Flag "unten")
        (vla-MoveBelow SortTbl EntArray (vlax-ename->vla-object objRef))
        (vla-MoveAbove SortTbl EntArray (vlax-ename->vla-object objRef)))))
  )




;;;--------------------------------------------------------------------------------------------------------
;;;Info für Textfenster nach dem laden des Programms							   
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(princ (strcat
          "\n|++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++|"
          "\n|PositionsNummern: Positionsnummern mit Kreisen              |"
          "\n|------------------------------------------------------------|"
          "\n|erstellt durch Bosse-engineering - www.bosse-engineering.com|"
          "\n|------------------------------------------------------------|"
          "\n|Befehlszeilenaufruf: PON oder POSITIONSNUMMERN              |"
	  "\n|++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++|"
          )
       )

(princ)








    

