
;;;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: FMK - Es werden Objekte ausgewählt, damit deren Layer in einer Liste aufgenommen werden     
;;;können. Diese Listeneinträge können Farbzuordnungen erhalten, die wiederum auf Objekte übertragen werden
;;;können. Der Farbwert kann die Eigenschaft von Layer oder von Objekt haben. Syncron dazu kann auch der   
;;;Transparenzwert gespeichert werden.									   
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;;;globale Variablen:										   	   
;;;- JB_FMK$DCL$_[x]_po (Positionen der Dialogfenster)							   
;;;- JB_FMK_$DCL$_File (temporäre DCL-Datei)								   
;;;                                                                              Jörn Bosse, 16.05.23	   
;;;--------------------------------------------------------------------------------------------------------



;;;aufrufenden Funktionen
(defun c:FMK ( / )
  (JB_FMK)
  )

;;;Intro
(defun JB_FMK:Intro (str / )
  (princ "\nerstellt durch Bosse-engineering - www.bosse-engineering.com\n")
  (princ "\n----------------------FMK(1.0), 16.05.23---------------------")
  (princ str)
  (princ "\n-------------------------------------------------------------")
  )




;;;Variablenliste
(defun JB_FMK:v_liste ( / )
  '(
     ( "DboxSettings" . (
                         ( "Dbox1" .
                            (
                             ( "JB_1_p1" .
                              (
                               ("<unbenannt>" .
                                (
                                 ("0" .
                                  (
                                   ("Color" . nil)
                                   ("ColorByLayer" . nil)
                                   ("Transp" . nil)
                                   ("TranspByLayer" . nil)
                                   )
                                  )                                 
                                 
                                 )
                                )
                               )
                              )
                             ( "LastName" . "<unbenannt>")
                             )
                          )
                         )
      ))
  )


;;;Pfad für SIC-Datei in Windows-User
(defun JB_FMK: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 
                           )"FMK_sic.lsp")  ;;;getauscht, z.B. c:\\User\\[WindowsUsername]\\LispData\\acad\\
  )

;;;Hauptfunktion
(defun JB_FMK ( / PFAD_INI V_LISTE OSMODE_ALT)
  (vl-load-com)

  (setq pfad_ini (JB_FMK: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_FMK:v_liste))pfad_ini nil))
  
  (vla-startundomark (vla-get-activedocument(vlax-get-acad-object)))
  (JBf_init
    '(("CMDECHO" 0)
      ("DIMZIN" 3)
      ))
  
  
  (JB_FMK:Intro "\nFMK: Farbmerker pro Layer.")

  
  

  (if (not
            (or (and JB_FMK_$DCL$_File(findfile JB_FMK_$DCL$_File))
                (setq JB_FMK_$DCL$_File (JB_FMK:dcl:Write))))
        (progn
          (alert "Die DCL-Datei konnte nicht geschrieben werden.")
          (exit)))

  (JB_FMK:Dbox1 v_liste pfad_ini)
   
  (princ "\nEnde.")
  (setq Osmode_Alt (getvar "OSMODE"))
  (JBf_Reinit)
  (setvar "OSMODE" Osmode_Alt)
  (vla-endundomark (vla-get-activedocument(vlax-get-acad-object))) 
  (princ)
  )

 

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


(defun JB_FMK: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
  )




;;;LAyerList aus AWS
(defun JB_FMK:Dbox1:LayerVonObjekten:LayerList (aws / LAYER LAYERLIST N VLA-OBJ X)
  (setq n 0)
  
  (repeat (sslength aws)
    (setq vla-obj (vlax-ename->vla-object(ssname aws n)))
    (setq layer (vla-get-layer vla-obj))
    (setq layerList (cons (strcase Layer) LayerList))
    (if (not (member (strcase layer) (mapcar 'strcase(mapcar 'car l1&Dbox1))))
      (setq l1&Dbox1 (append l1&Dbox1 (list(cons layer '(("Color" . nil)
                                                   ("ColorByLayer" . nil)
                                                   ("Transp" . nil)
                                                   ("TranspByLayer" . nil)
                                                   )))))
      )
    (setq n (+ n 1)))
  (setq l1&Dbox1 (vl-sort l1&Dbox1 '(lambda(e1 e2)(< (car e1)(car e2)))))
  (setq n -1)
  (setq l1_sel&Dbox1 nil)
  (mapcar '(lambda(X)
             (setq n (+ n 1))
             (if (member(strcase(car X))LayerList)
               (setq l1_sel&Dbox1 (cons n l1_sel&Dbox1))
               )
             )
    l1&Dbox1)
  (setq l1_sel&Dbox1 (reverse l1_sel&Dbox1))
  )
                             
  


;;;LAyer aus auszuwählenden Objekten
(defun JB_FMK:Dbox1:LayerVonObjekten ( / AWS)
  (if(setq aws (ssget))
    (JB_FMK:Dbox1:LayerVonObjekten:LayerList aws)
    )
  )

;;;DBox 1
(defun JB_FMK:Dbox1 (v_liste pfad_ini / DCLID OK l1&Dbox1 l1_sel&Dbox1 p1&Dbox1 p1_sel&Dbox1 SETTINGS&DBOX1 A)
  
  (setq Settings&Dbox1 (JB_FMK:v_liste:DboxSettings:get "Dbox1" v_liste))
  (setq p1&Dbox1 (cdr(assoc "JB_1_p1" Settings&Dbox1))) 
  (setq p1_sel&Dbox1 (-(length p1&Dbox1)(length (member (cdr(assoc "LastName" Settings&Dbox1))(mapcar 'car p1&Dbox1)))))
  (setq l1&Dbox1 (cdr(nth p1_sel&Dbox1 p1&Dbox1)))  
  (setq l1_sel&Dbox1 '(0))
    
  (while (not (member ok '(1 99)))

    (setq DclId (JBf_Dcl:Load_dialog JB_FMK_$DCL$_File "JB_FMK_1" JB_FMK$DCL$_1_po))

    (JB_FMK:Dbox1:set)
    (JB_FMK:Dbox1:mode)
    
    
    (mapcar '(lambda (A) (action_tile A (strcat "(JB_FMK:Dbox1:action \"" A "\")")))
            '("JB_1_b10" "JB_1_b11" "JB_1_b12" "JB_1_b13" 
              "JB_1_b1" "JB_1_b2" "JB_1_b3" "JB_1_b4"
              "JB_1_l1" "JB_1_p1"
                         
	      "accept" "cancel"
             )
    )
    (setq ok (start_dialog))
    (unload_dialog DclId)
    
    (cond ((= ok 99) ;;;Ende
           (setq v_liste (JB_FMK:v_liste:DboxSettings:put "Dbox1" Settings&dbox1 v_liste))
           (JBf_SIC:sichern v_liste pfad_ini nil)
           )
          ((= ok 11);;;Objekte aus Zeichnung für Layerliste
           (JB_FMK:Dbox1:LayerVonObjekten)
           )
           
          ((= ok 1);;;Farben und Teansparenz anbringen
           (setq v_liste (JB_FMK:v_liste:DboxSettings:put "Dbox1" Settings&dbox1 v_liste))
           (JBf_SIC:sichern v_liste pfad_ini nil)
           (JB_FMK:Dbox1:exe)
           )
          
          )
    ) 
  )

;;;Dbox 1, aktuelle Definition speichern
(defun JB_FMK:Dbox1:action:Def:Save ( / )
  (setq p1&Dbox1 (JBf_list:nth:change p1&Dbox1 (cons (car (nth p1_sel&Dbox1 p1&Dbox1))l1&Dbox1)p1_sel&Dbox1))
  (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 p1&Dbox1 "JB_1_p1"))
  'T)

;;;Dbox 1, action p1
(defun JB_FMK:Dbox1:action:p1 ( / )
  (if (/= (car (nth (atoi $value)p1&Dbox1))
          (car (nth p1_sel&Dbox1 p1&Dbox1)))
    (if (or(not(JB_FMK:Dbox1:DefChange-p))
             (and
               (= 1(JB_FMK:Dbox5 "Die Konfigurationsliste wurde geändert, vorher speichern?"))
               (JB_FMK:Dbox1:action:Def:Save)))
        (progn
          (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 (car (nth (atoi $value)p1&Dbox1))"LastName")
                p1_sel&Dbox1 (atoi $value)
                l1&Dbox1 (cdr(nth p1_sel&Dbox1 p1&Dbox1))
                l1_sel&Dbox1 '(0))
          (JB_FMK:Dbox1:set)
          (JB_FMK:Dbox1:mode)
          )
        )
    )
  )

;;;DBox1, Eigenschaft löschen
(defun JB_FMK:Dbox1:action:b4 ( / N X)
  (setq n -1)
  (setq l1&Dbox1
         (vl-remove-if 'not
           (mapcar '(lambda(X)
                      (setq n (+ n 1))
                      (if (not(member n l1_sel&Dbox1))
                        X))l1&Dbox1)))
  (if (not l1&Dbox1)
    (setq l1&Dbox1 '(
                     ("0" . (
                             ("Color" . nil)
                             ("ColorByLayer" . nil)
                             ("Transp" . nil)
                             ("TranspByLayer" . nil)
                             )
                      )
                     )
          l1_sel&Dbox1 '(0))
    (if (> (car l1_sel&Dbox1) 0)
      (setq l1_sel&Dbox1 (list(- (car l1_sel&Dbox1) 1)))
      (setq l1_sel&Dbox1 '(0))
      )
    )
  (JB_FMK:Dbox1:set)
  (JB_FMK:Dbox1:mode)
  )

;;;DBox1, Definition speichern unter
(defun JB_FMK:Dbox1:action:b11 ( / WERT X)
  (if (and(setq wert (JB_FMK:Dbox4 "Konfigurationsname"
                   (car (nth p1_sel&Dbox1 p1&Dbox1))))
          (or(not(member (strcase wert)(mapcar 'strcase(mapcar 'car p1&Dbox1))))
             (alert (strcat "Der Konfigurationsname \"" wert "\" ist bereits vorhanden."))))
    (if(or(not(JB_FMK:Dbox1:DefChange-p))
          (= 99(JB_FMK:Dbox5 "Die Konfigurationsliste wurde geändert, vorher speichern?"))
          (and            
            (JB_FMK:Dbox1:action:Def:Save)
            (or(JB_FMK:Dbox1:set)'T)))
      (progn
        (setq p1&Dbox1 (vl-sort(append p1&Dbox1 (list (cons wert l1&Dbox1)))'(lambda(e1 e2)(<(car e1)(car e2)))))
        (JB_FMK:Dbox1:action:b11-12:p1_sel wert)
        )
      )
    )
  )

;;;DBox1, Definition umbenennen
(defun JB_FMK:Dbox1:action:b12 ( / WERT X)
  (if (and(setq wert (JB_FMK:Dbox4 "Konfigurationsname"
                   (car (nth p1_sel&Dbox1 p1&Dbox1))))
          (or(not(member (strcase wert)(mapcar 'strcase(mapcar 'car p1&Dbox1))))
             (alert (strcat "Der Konfigurationsname \"" wert "\" ist bereits vorhanden."))))
    (if(or(not(JB_FMK:Dbox1:DefChange-p))
          (and
            (= 1(JB_FMK:Dbox5 "Die Konfigurationsliste wurde geändert, vorher speichern?"))
            (JB_FMK:Dbox1:action:Def:Save)
            (or(JB_FMK:Dbox1:set)'T)))
      (progn
        (setq p1&Dbox1 (vl-sort(JBf_list:nth:change p1&Dbox1 (cons wert (cdr(nth p1_sel&Dbox1 p1&Dbox1))) p1_sel&Dbox1)'(lambda(e1 e2)(<(car e1)(car e2)))))
        (JB_FMK:Dbox1:action:b11-12:p1_sel wert)
        )
      )
    )
  )

 

;;;DBox, Definition, p1_sel und weiteres
(defun JB_FMK:Dbox1:action:b11-12:p1_sel (wert / N X)
  (setq n -1)
  (mapcar '(lambda(X)
             (setq n (+ n 1))
             (if (= wert (car X))
               (setq p1_sel&Dbox1 n)))p1&Dbox1)
  (setq l1&Dbox1 (cdr(nth p1_sel&Dbox1 p1&Dbox1)))
  (setq l1_sel&Dbox1 '(0))
  (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 (car (nth p1_sel&Dbox1 p1&Dbox1))"LastName"))
  (JB_FMK:Dbox1:set)
  (JB_FMK:Dbox1:mode)
  (JB_FMK:Dbox1:action:Def:Save)
  )


;;;DBox1, Definition löschen
(defun JB_FMK:Dbox1:action:b13 ( / N X )
  (if(= 1(JB_FMK:Dbox5 (strcat "Die Konfigurationsliste \"" (car(nth p1_sel&Dbox1 p1&Dbox1))"\" wird gelöscht, fortfahren?")))
    (progn
      (setq n -1)
      (setq p1&Dbox1
             (vl-remove-if 'not
               (mapcar '(lambda(X)
                          (setq n (+ n 1))
                          (if (/= n p1_sel&Dbox1)
                            X))p1&Dbox1)))
      (if (/= p1_sel&Dbox1 0)
        (setq p1_sel&Dbox1 (- p1_sel&Dbox1 1)))
      (setq l1&Dbox1 (cdr(nth p1_sel&Dbox1 p1&Dbox1)))
      (setq l1_sel&Dbox1 '(0))
      (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 (car (nth p1_sel&Dbox1 p1&Dbox1))"LastName"))
      (JB_FMK:Dbox1:set)
      (JB_FMK:Dbox1:mode)
      (JB_FMK:Dbox1:action:Def:Save)

      )
    )
  )
 
   
;;;Action (Variable global in Aufrufender Funktion)
(defun JB_FMK:Dbox1:action (key / NAME X)

  (cond
    ((= key "JB_1_p1")
     (JB_FMK:Dbox1:action:p1)     
     )
    ((= key "JB_1_b10");;;Speichern
     (JB_FMK:Dbox1:action:Def:Save)
     (JB_FMK:Dbox1:set)
     )
    ((= key "JB_1_b11");;;Speichern unter
     (JB_FMK:Dbox1:action:b11)
     )
    ((= key "JB_1_b12");;;umbenennen
     (JB_FMK:Dbox1:action:b12)
     )
    ((= key "JB_1_b13");;;löschen
     (JB_FMK:Dbox1:action:b13)
     )
    ((= key "JB_1_b1") ;;;Layer neu aus Objekten
     (setq JB_FMK$DCL$_1_po (done_dialog 11))     
     )
    ((= key "JB_1_b2") ;;;Farbe
     (JB_FMK:Dbox2)
     (JB_FMK:Dbox1:set)
     )
    ((= key "JB_1_b3") ;;;Transparenz
     (JB_FMK:Dbox3)
     (JB_FMK:Dbox1:set)
     )
    ((= key "JB_1_b4");;;Layer aus Liste löschen
     (JB_FMK:Dbox1:action:b4)
     )
    ((= key "JB_1_l1")
     (setq l1_sel&Dbox1 (mapcar 'atoi(JBf_String:Delimiter->List $value " ")))
     (if (= $reason 4)
       (progn
         (JB_FMK:Dbox2)
         (JB_FMK:Dbox1:set)
         )
       )
     )    
    ((= key "accept") ;;;Stempel anbringen
     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 key "LastButton"))
     (if(JB_FMK:Dbox1:DefChange-p)
       (if(= 1(JB_FMK:Dbox5 "Die Konfigurationsliste wurde geändert, vorher speichern?"))
         (progn
           (JB_FMK:Dbox1:action:Def:Save)
           (setq JB_FMK$DCL$_1_po (done_dialog 1))
           )
         )
       (setq JB_FMK$DCL$_1_po (done_dialog 1)))
     )
    ((= key "JB_1_b4") ;;;Stempel entfernen
     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 key "LastButton"))
     (if(JB_FMK:Dbox1:DefChange-p)
       (if(= 1(JB_FMK:Dbox5 "Die Konfigurationsliste wurde geändert, vorher speichern?"))
         (progn
           (JB_FMK:Dbox1:action:Def:Save)
           (setq JB_FMK$DCL$_1_po (done_dialog 14))
           )
         )
       (setq JB_FMK$DCL$_1_po (done_dialog 14)))
     )

    ((= key "JB_1_b5") ;;;Stempel wieder herstellen
     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 key "LastButton"))
     (if(JB_FMK:Dbox1:DefChange-p)
       (if(= 1(JB_FMK:Dbox5 "Die Konfigurationsliste wurde geändert, vorher speichern?"))
         (progn
           (JB_FMK:Dbox1:action:Def:Save)
           (setq JB_FMK$DCL$_1_po (done_dialog 15))
           )
         )
       (setq JB_FMK$DCL$_1_po (done_dialog 15)))
     )

    ((= key "cancel") ;;;Ende
     (if(JB_FMK:Dbox1:DefChange-p)
       (if(= 1(JB_FMK:Dbox5 "Die Konfigurationsliste wurde geändert, vorher speichern?"))
         (JB_FMK:Dbox1:action:Def:Save)))
     (setq JB_FMK$DCL$_1_po (done_dialog 99))
     )
    )
    
)

(defun JB_FMK:Dbox1:DefChange-p ( / )
  (/= (vl-prin1-to-string (cdr(assoc (cdr(assoc "LastName" Settings&Dbox1))p1&Dbox1)))
      (vl-prin1-to-string l1&Dbox1))  
  )
    
;;;DBox1: setten
(defun JB_FMK:Dbox1:set ( / SternString X)
  (setq SternString(if (JB_FMK:Dbox1:DefChange-p)"***" ""))

  (JBf_Dcl:AddList:New "JB_1_p1"
    (mapcar '(lambda(X)
               (if (= X(car(assoc (cdr(assoc "LastName" Settings&Dbox1))p1&Dbox1)))
                 (strcat SternString X)
                 X))(mapcar 'car p1&Dbox1))
    )
  (set_tile "JB_1_p1" (itoa p1_sel&Dbox1))

  (JBf_Dcl:AddList:New "JB_1_l1"
    (mapcar '(lambda (X)
               (strcat
                 (if (not(tblsearch "LAYER" (car X)))"***" "")
                 (car X) "\t"
                 " => | Farbe "
                 (if (=(cdr(assoc "ColorByLayer"(cdr X)))"1") "(vonLayer) " "")
                 "= " (if (and(cdr X)(cdr(assoc 62(cdr(assoc "Color"(cdr X))))))
                               (JBf_dbox_layer_set:farbe:string
                                 (cdr(assoc 62 (cdr(assoc "Color"(cdr X)))))
                                 (cdr(assoc 420 (cdr(assoc "Color"(cdr X)))))
                                 (cdr(assoc 430 (cdr(assoc "Color"(cdr X))))))
                               "-")
                 " | Transparenz "
                 (if (=(cdr(assoc "TranspByLayer"(cdr X)))"1") "(vonLayer) " "")
                 "= "(if (and(cdr X)(cdr(assoc "Transp"(cdr X))))
                               (itoa(cdr(assoc "Transp"(cdr X))))
                                    "-")
                 )
               )
      l1&Dbox1))
  (set_tile "JB_1_l1" "")
  (set_tile "JB_1_l1" (vl-string-right-trim " "(apply 'strcat(mapcar '(lambda(X)(strcat X " "))(mapcar 'itoa l1_sel&Dbox1)))))
  )
;;;DBox1, moden
(defun JB_FMK:Dbox1:mode ( / )
  (if (=(length p1&Dbox1)1)
    (mode_tile "JB_1_b13" 1)
    (mode_tile "JB_1_b13" 0)
    )

  (if (=(length l1&Dbox1)1)
    (mode_tile "JB_1_b4" 1)
    (mode_tile "JB_1_b4" 0)
    )

  
  )

;;;DBox2, setten, Farbicon als Kreuz
(defun JB_FMK:Dbox2:set:Image:Kreuz ( / VERB)
  (setq verb (/ (dimx_tile "JB_2_i1") 8))
	
  (start_image "JB_2_i1")
  (fill_image 0 0 (dimx_tile "JB_2_i1") (dimy_tile "JB_2_i1") 253)
 
  (vector_image (+ 0 verb) (+ 0 verb)(-(dimx_tile "JB_2_i1")verb) (-(dimy_tile "JB_2_i1")verb) 32)
  (vector_image (+ verb 0) (- (dimy_tile "JB_2_i1")verb) (-(dimx_tile "JB_2_i1")verb) (+ verb 0) 32)
  (vector_image (+ 0 verb) (+ 0 verb) (-(dimx_tile "JB_2_i1")verb) (+ 0 verb) 32)
  (vector_image (- (dimx_tile "JB_2_i1")verb) (+ 0 verb)(-(dimx_tile "JB_2_i1")verb)(-(dimy_tile "JB_2_i1")verb)32)
  (vector_image (- (dimx_tile "JB_2_i1")verb) (-(dimy_tile "JB_2_i1")verb) (+ 0 verb) (-(dimy_tile "JB_2_i1")verb) 32)
  (vector_image (+ 0 verb) (- (dimy_tile "JB_2_i1")verb) (+ 0 verb) (+ 0 verb) 32)
  
  (end_image)
  )


                      


;;;DBox2, setten
(defun JB_FMK:Dbox2:set ( / X)
  (mapcar '(lambda (X)
             (set_tile (strcat "JB_2_" (car X))
               (cadr X)
               )
             )
    (list
      (list "to1" (if (= ByLayer&Dbox2 "*VARIIERT*") "1" (if ByLayer&Dbox2 ByLayer&Dbox2 "0")))
      (list "t1" (strcat "Farbe: "
                   (if Color&Dbox2
                   (if (= Color&Dbox2 "*VARIIERT*")
                     "*VARIIERT*"
                     (JBf_dbox_layer_set:farbe:string
                       (cdr(assoc 62 Color&Dbox2))
                       (cdr(assoc 420 Color&Dbox2))
                       (cdr(assoc 430 Color&Dbox2))))
                   "-"))
            )
      )
    )
    
    
  (if (or (not Color&Dbox2)(= Color&Dbox2 "*VARIIERT*"))
    (JB_FMK:Dbox2:set:Image:Kreuz)
    (progn
      (start_image "JB_2_i1")
      (fill_image 0 0 (dimx_tile "JB_2_i1") (dimy_tile "JB_2_i1") (cdr(assoc 62 Color&Dbox2)))
      (end_image)
      )
    )

  (if (= ByLayer&Dbox2 "*VARIIERT*")
    (alert "Hinweis: bei den ausgewählten Layern variiert die Eigenschaft \"vonLayer\".")
    )
  
)


;;;DBox2 => Color
(defun JB_FMK:DBox2:Color ( / COLORLIST X)
  (setq ColorList(mapcar '(lambda(X)
                            (cdr(assoc "Color" (cdr X))))subList&DBox2))
  (if (not (vl-remove-if '(lambda(X)
                            (=(vl-prin1-to-string (car ColorList))
                              (vl-prin1-to-string X)))ColorList))
    (setq Color&Dbox2 (car ColorList))
    (setq Color&Dbox2 "*VARIIERT*"))
  )

;;;DBox2 => Transparenz
(defun JB_FMK:DBox2:ByLayer ( / BYLAYERLIST X)
  (setq ByLayerList(mapcar '(lambda(X)
                            (cdr(assoc "ColorByLayer" (cdr X))))subList&DBox2))
  (if (not (vl-remove-if '(lambda(X)
                            (=(vl-prin1-to-string (car ByLayerList))
                              (vl-prin1-to-string X)))ByLayerList))
    (setq ByLayer&Dbox2 (car ByLayerList))
    (setq ByLayer&Dbox2 "*VARIIERT*"))
  )

;;;DBox2 => SubList
(defun JB_FMK:Dbox2:SubList ( / N X)
  (setq n -1)
  (setq subList&DBox2
         (vl-remove-if 'not
           (mapcar '(lambda(X)
                      (setq n (+ n 1))
                      (if (member n l1_sel&Dbox1)
                        X))l1&Dbox1)))
  )

;;;SubList => l1
(defun JB_FMK:Dbox2:SubList2L1 ( / X)
  (setq l1&Dbox1
         (mapcar '(lambda(X)
                    (if (assoc (car X)subList&DBox2)
                      (cons (car (assoc (car X)subList&DBox2))
                            (list (cons "Color" (if(= Color&Dbox2 "*VARIIERT*")
                                                  (cdr(assoc "Color"(cdr X)))
                                                  Color&Dbox2))
                                  (cons "ColorByLayer" (if(= ByLayer&Dbox2 "*VARIIERT*")
                                                         (cdr(assoc "ColorByLayer"(cdr X)))
                                                         ByLayer&Dbox2))
                                  (assoc "Transp" (cdr X))
                                  (assoc "TranspByLayer" (cdr X))))
                      X))l1&Dbox1)
        )
  )

       
;;;DBox2 => Farbe
(defun JB_FMK:Dbox2 ( / subList&DBox2 Color&Dbox2 ByLayer&Dbox2 DclId ok A)

  
  (JB_FMK:Dbox2:SubList)
  (JB_FMK:DBox2:Color)
  (JB_FMK:DBox2:ByLayer)


  (while (not (member ok '(1 99)))

    (setq DclId (JBf_Dcl:Load_dialog JB_FMK_$DCL$_File "JB_FMK_2" JB_FMK$DCL$_2_po))

    (JB_FMK:Dbox2:set)
    
    (mapcar (function (lambda (A) (action_tile A (strcat "(JB_FMK:Dbox2:action \"" A "\")"))))
            '(
               "JB_2_i1" "JB_2_to1"
               "accept" "cancel"
             )
    )

    (setq ok (start_dialog))
    (unload_dialog DclId)


    (if (= ok 1)
      (JB_FMK:Dbox2:SubList2L1)
      )
  )
  )


;;;Action (Variable global in Aufrufender Funktion)
(defun JB_FMK:Dbox2:action (key / COLOR)

  (cond
    ((= key "JB_2_i1")
     (if(or(= Color&Dbox2 "*VARIIERT*")
           (not Color&Dbox2))
       (if (tblsearch "LAYER"(car(car subList&DBox2)))
         (setq color (vl-remove-if '(lambda(X)(not(member (car X)'(62 420 430))))
                       (entget(vlax-vla-object->ename(vla-item(vla-get-layers(vla-get-activedocument(vlax-get-acad-object)))(car(car subList&DBox2)))))))
         (setq color '((62 . 7)))
         )
       (setq color Color&Dbox2)
       )
     (if(setq color(acad_truecolordlg (cond ((cdr(assoc 430 color))
                                             (assoc 430 color))
                                            ((cdr(assoc 420 color))
                                             (assoc 420 color))
                                            ('T (assoc 62 color)))nil))
       (progn
         (setq Color&Dbox2 (vl-remove-if 'not
                             (list (assoc 62 color)
                                   (assoc 420 color)
                                   (assoc 430 color))))
         (JB_FMK:Dbox2:set)
         )
       )
     )
    ((= key "JB_2_to1")
     (setq ByLayer&Dbox2 $value)
     )
    ((= key "accept");;;Auswahl mit OK abschließen     
     (setq JB_FMK$DCL$_2_po (done_dialog 1))
    )
    ((= key "cancel")    ;;;Abbrechen
     (setq JB_FMK$DCL$_2_po (done_dialog 99))
    )

  )
)



;;;DBox3 => Transparenz
(defun JB_FMK:DBox3:Transp ( / TRANSPLIST)
  (setq TranspList(mapcar '(lambda(X)
                            (cdr(assoc "Transp" (cdr X))))subList&DBox3))
  (if (not (vl-remove-if '(lambda(X)
                            (=(vl-prin1-to-string (car TranspList))
                              (vl-prin1-to-string X)))TranspList))
    (setq Transp&Dbox3 (car TranspList))
    (setq Transp&Dbox3 "*VARIIERT*"))
  )

;;;DBox3 => Transparenz
(defun JB_FMK:DBox3:ByLayer ( / BYLAYERLIST X)
  (setq ByLayerList(mapcar '(lambda(X)
                            (cdr(assoc "TranspByLayer" (cdr X))))subList&DBox3))
  (if (not (vl-remove-if '(lambda(X)
                            (=(vl-prin1-to-string (car ByLayerList))
                              (vl-prin1-to-string X)))ByLayerList))
    (setq ByLayer&Dbox3 (car ByLayerList))
    (setq ByLayer&Dbox3 "*VARIIERT*"))
  )

;;;DBox3 => SubList
(defun JB_FMK:Dbox3:SubList ( / N X)
  (setq n -1)
  (setq subList&DBox3
         (vl-remove-if 'not
           (mapcar '(lambda(X)
                      (setq n (+ n 1))
                      (if (member n l1_sel&Dbox1)
                        X))l1&Dbox1)))
  )


;;;DBox3, setten
(defun JB_FMK:Dbox3:set ( / X)
  (mapcar '(lambda (X)
             (set_tile (strcat "JB_3_" (car X))
               (cadr X)
               )
             )
    (list
      (list "to1" (if (= ByLayer&Dbox3 "*VARIIERT*") "1" (if ByLayer&Dbox3 ByLayer&Dbox3 "0")))
      (list "t1" (strcat "Transparenzwert: "
                   (if Transp&Dbox3
                   (if (= Transp&Dbox3 "*VARIIERT*")
                     "*VARIIERT*"
                     (itoa Transp&Dbox3))
                   "-"))
            )
      )
    )
  (if (= ByLayer&Dbox3 "*VARIIERT*")
    (alert "Hinweis: bei den ausgewählten Layern variiert die Eigenschaft \"vonLayer\".")
    )
  
)


;;;DBox3 => Transparenz
(defun JB_FMK:Dbox3 ( / subList&DBox3 Transp&Dbox3 ByLayer&Dbox3 DclId ok A)

  
  (JB_FMK:Dbox3:SubList)
  (JB_FMK:DBox3:Transp)
  (JB_FMK:DBox3:ByLayer)


  (while (not (member ok '(1 99)))

    (setq DclId (JBf_Dcl:Load_dialog JB_FMK_$DCL$_File "JB_FMK_3" JB_FMK$DCL$_3_po))

    (JB_FMK:Dbox3:set)
    
    (mapcar (function (lambda (A) (action_tile A (strcat "(JB_FMK:Dbox3:action \"" A "\")"))))
            '(
               "JB_3_b1" "JB_3_to1"
               "accept" "cancel"
             )
    )

    (setq ok (start_dialog))
    (unload_dialog DclId)


    (if (= ok 1)
      (JB_FMK:Dbox3:SubList2L1)
      )
  )
  )

(defun JB_FMK:Dbox3:action:Layer:getTransp (name / OBJLAYER TRANSP)
  (if (setq objLayer (tblobjname "LAYER" name))
    (if (setq transp(cdr (assoc 1071 (cdadr (assoc -3 (entget objLayer '("AcCmTransparency")))))))
      (fix (- 100 (/ (logand transp -33554433) 2.55)))
      0
      )
    )
  )

;;;Action (Variable global in Aufrufender Funktion)
(defun JB_FMK:Dbox3:action (key / transp)


;;;  (vla-item(vla-get-layers(vla-get-activedocument(vlax-get-acad-object)))"0")
;;;
;;;  vla-put-Transparency
  (cond
    ((= key "JB_3_b1")
     (if(or(= Transp&Dbox3 "*VARIIERT*")
           (not Transp&Dbox3))
       (if (tblsearch "LAYER"(car(car subList&DBox3)))
         (setq transp (JB_FMK:Dbox3:action:Layer:getTransp(car(car subList&DBox3))))
         (setq transp 0)
         )
       (setq transp 0)
       )
     (if(and(setq transp (JB_FMK:Dbox4 "Transparenzwert (0-90)" (itoa transp)))
            (or
              (and (>= (atoi transp)0)(<= (atoi transp)90))
              (alert "Der Transparenzwert muss ein Wert von 0 bis 90 sein.")
              )
            )
       (progn
         (setq Transp&Dbox3 (atoi transp))
         (JB_FMK:Dbox3:set)
         )
       )
     )
    ((= key "JB_3_to1")
     (setq ByLayer&Dbox3 $value)
     )
    ((= key "accept");;;Auswahl mit OK abschließen     
     (setq JB_FMK$DCL$_3_po (done_dialog 1))
    )
    ((= key "cancel")    ;;;Abbrechen
     (setq JB_FMK$DCL$_3_po (done_dialog 99))
    )

  )
)

;;;SubList => l1
(defun JB_FMK:Dbox3:SubList2L1 ( / X)
  (setq l1&Dbox1
         (mapcar '(lambda(X)
                    (if (assoc (car X)subList&DBox3)
                      (cons (car (assoc (car X)subList&DBox3))
                            (list (assoc "Color" (cdr X))                                  
                                  (assoc "ColorByLayer" (cdr X))
                                  (cons "Transp" (if (= Transp&Dbox3 "*VARIIERT*")
                                                   (cdr(assoc "Transp"(cdr X)))
                                                   Transp&Dbox3))
                                  (cons "TranspByLayer" (if(= ByLayer&Dbox3 "*VARIIERT*")
                                                          (cdr(assoc "TranspByLayer"(cdr X)))
                                                          ByLayer&Dbox3))))
                      X))l1&Dbox1)
        )
  )


;;;DBox4, Textwert zurückgeben
(defun JB_FMK:Dbox4 (Header wert / ok DclId)

  (while (not (member ok '(1 99)))

    (setq DclId (JBf_Dcl:Load_dialog JB_FMK_$DCL$_File "JB_FMK_4" JB_FMK$DCL$_4_po))

    (set_tile "JB_4" header)
    (set_tile "JB_4_e1" wert)
    (mode_tile "JB_4_e1" 2)


    (mapcar (function (lambda (A) (action_tile A (strcat "(JB_FMK:Dbox4:action \"" A "\")"))))
            '(

               "accept" "cancel"
             )
    )

    (setq ok (start_dialog))
    (unload_dialog DclId)



  )
       wert
)

;;;Action (Variable global in Aufrufender Funktion)
(defun JB_FMK:Dbox4:action (key /)

  (cond
    ((= key "accept")  ;;;Auswahl mit OK abschließen
        (setq wert (get_tile "JB_4_e1"))
        (setq JB_FMK$DCL$_3_po (done_dialog 1))
    )
    ((= key "cancel")  ;;;Abbrechen
        (setq wert nil)
        (setq JB_FMK$DCL$_3_po (done_dialog 99))
    )

  )
)



(defun JB_FMK:Dbox5 (frage / DclId ok)
  (setq DclId (JBf_Dcl:Load_dialog JB_FMK_$DCL$_File "JB_FMK_5" JB_FMK$DCL$_4_po))
  ;;;Button-Action
  (set_tile "JB_jn" frage)
  (action_tile "JB_nein" "(done_dialog 99)") ;Nein
  (action_tile "JB_ja" "(done_dialog 1)") ;Ja
  (setq ok (start_dialog))
  (unload_dialog DclId)
  ok)

         
;;;DCL-schreiben
(defun JB_FMK:dcl:Write ( / file)  
  (if (and (setq JB_FMK_$DCL$_File (vl-filename-mktemp (strcat "FMK.dcl")))
           (setq file (open JB_FMK_$DCL$_File "w"))
      )
    (progn
      (mapcar '(lambda (A)
                       (write-line A file)
               )
              (mapcar '(lambda (A)
                               (strcat "\n" A)
                       )
              (list
                "//Hauptdialog"
                "JB_FMK_1: dialog {label= \"Farbmerker pro Layer\";	 "
                ":boxed_column {label = \"Konfiguration\";"
                ":popup_list {key = \"JB_1_p1\";}"
                ":row {"
                ":button {key = \"JB_1_b10\"; label = \"Spei&chern\";}"
                ":button {key = \"JB_1_b11\"; label = \"&Speichern unter...\";}"
                ":button {key = \"JB_1_b12\"; label = \"U&mbenennen...\";}"
                ":button {key = \"JB_1_b13\"; label = \"Lösc&hen\";}}}"
                ":boxed_column{label = \"Layer-Farbliste\";"
                ":list_box {key = \"JB_1_l1\"; label = \"Layer-Farbe-Transparenz (Mehrfachauswahl mit STRG+UMSCHALT)\";width=120; height=25; multiple_select = true;tabs=\"30\";}"
                ":row{"
                ":button{key = \"JB_1_b1\"; label = \"&Neu...\";}"
                ":button{key = \"JB_1_b2\"; label = \"&Farbe...\";}"
                ":button{key = \"JB_1_b3\"; label = \"&Transparenz...\";}"
                ":button{key = \"JB_1_b4\"; label = \"&Löschen\";}"
                "}"
                "}"
                ":row{fixed_width = true;alignment = centered;"
                ":retirement_button {label = \"&Anwenden<\"; key= \"accept\"; fixed_width = true;is_default=true;}"
                ":spacer { width = 2;}"
                ":retirement_button {label = \"&Ende\"; key= \"cancel\"; fixed_width = true;is_cancel=true;}"
                "}"
                "}"
                "JB_FMK_2: dialog {label= \"Farbmerker\";"
                ":boxed_column {label = \"Farbe\";"
                ":toggle {key = \"JB_2_to1\"; label = \"vonLayer\";}"
                ":row {"
                ":text {key = \"JB_2_t1\"; label = \"Farbe: RAL CLASSIC$RAL 1003\";width =30;}"
                ":image_button {width=5; height=2;key = \"JB_2_i1\"; fixed_width=true;fixed_height=true;}}"
                "}"
                "ok_cancel;}"
                "JB_FMK_3: dialog {label= \"Farbmerker - Transparenz\";"
                ":boxed_column {label = \"Transparenz\";"
                ":toggle {key = \"JB_3_to1\"; label = \"vonLayer\";}"
                ":row {"
                ":text  {key = \"JB_3_t1\"; label = \"Transparenz für Farbflächen: 0\";width = 30;}"
                ":button {key = \"JB_3_b1\"; label = \"...\";width = 5;}}"
                "}"
                "ok_cancel;}"
                "JB_FMK_4: dialog {key = \"JB_4\";"
                ":boxed_column {label = \"bitte eingeben:\";"
                ":edit_box {key = \"JB_4_e1\"; allow_accept=true;}"
                "}"
                "ok_cancel;}"
                "JB_FMK_5: dialog {label = \"Frage: Ja oder Nein\";"
                ":text {value = \"Hier kommt die zu bejahende oder beneinende Frage hin.\"; key =\"JB_jn\"; width = 100;}"
                ":row {fixed_width = true;alignment = centered;"
                ":retirement_button {label= \" Ja \"; key   = \"JB_ja\"; is_default  = true; }"
                ":spacer {width = 2; }"
                ":retirement_button {label = \"Nein\"; key = \"JB_nein\"; is_cancel= true;}}}"

               )
              )
      )
      (close file)
      JB_FMK_$DCL$_File
    )
  )
)


(defun c:testobj ( / )
  (setq color (list (cons 62 75)(cons 420 7900484)))
  (if (setq obj (car(entsel)))
    (entmod (append (vl-remove-if '(lambda(X)(member (car X)'(62 420 430)))(entget obj))color))
    )
  )


(defun c:testLayer ( / )
  (setq color (list (cons 62 75)(cons 420 7900484)))
  (if (setq obj (car(entsel)))
    (progn
      (setq layer (vlax-vla-object->ename (vla-item(vla-get-layers(vla-get-activedocument(vlax-get-acad-object)))(vla-get-layer(vlax-ename->vla-object obj)))))
      (entmod (append (vl-remove-if '(lambda(X)(member (car X)'(62 420 430)))(entget layer))color))
    )
  )
  )

    

;;;Farben auf Obejkte oder Objektlayer anbringen
(defun JB_FMK:Dbox1:exe ( / AWS AWSERROR LAYER N SUB)
  (setq awsError (ssadd))
  (if (setq aws (ssget))
    (progn
      (setq n 0)
      (repeat (sslength aws)
        ;;;Farbe
        (if(setq sub (cdr(assoc (vla-get-layer(vlax-ename->vla-object(ssname aws n)))l1&Dbox1)))
          (progn
            (if (cdr(assoc "Color" sub))
              (if (=(cdr(assoc "ColorByLayer" sub))"1")
                (progn
                  (setq layer (vlax-vla-object->ename (vla-item(vla-get-layers(vla-get-activedocument(vlax-get-acad-object)))(vla-get-layer(vlax-ename->vla-object (ssname aws n))))))
                  (entmod (append (vl-remove-if '(lambda(X)(member (car X)'(62 420 430)))(entget layer))(cdr(assoc "Color" sub))))
                  (vla-put-color (vlax-ename->vla-object(ssname aws n))256)
                  )
                (entmod (append (vl-remove-if '(lambda(X)(member (car X)'(62 420 430)))(entget (ssname aws n)))(cdr(assoc "Color" sub))))
                )
              )
            (if (cdr(assoc "Transp" sub))
              (if (=(cdr(assoc "TranspByLayer" sub))"1")
                (progn
                  (JB_FMK:Dbox1:exe:Layer:setTransp(vla-get-layer(vlax-ename->vla-object (ssname aws n)))(itoa(cdr(assoc "Transp" sub))))
                  (JB_FMK:Dbox1:exe:vla-obj:setTransp (vlax-ename->vla-object (ssname aws n)) "vonLayer")
                  )
                (JB_FMK:Dbox1:exe:vla-obj:setTransp (vlax-ename->vla-object (ssname aws n))(itoa(cdr(assoc "Transp" sub))))
                )
              )
            )
          (ssadd (ssname aws n)awsError))
        (setq n (+ n 1)))
      )
    )
  (if (and awsError (/=(sslength awsError)0))
    (progn
      (alert "Es wurden Objekte ausgewählt, deren Layer nicht in der Programmliste vorhanden waren, diese Objekte werden abschließend selektiert.")
      (sssetfirst awsError awsError)
      )
    )
  )
;;;LAyerTransparenz setzen
(defun JB_FMK:Dbox1:exe:Layer:setTransp(Name transp /)
  (if (tblsearch "LAYER" Name)
    (command "_.-layer" "_TR" transp Name "")
        )
    )

;;;Objekt-Transparenz setzen
(defun JB_FMK:Dbox1:exe:vla-obj:setTransp (vla-obj transp / )
  (if(and transp(vlax-property-available-p vla-obj 'EntityTransparency))
   (vla-put-EntityTransparency vla-obj transp)
    )
  )

;;;--------------------------------------------------------------------------------------------------------
;;;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 auf dem Benutzer von Windows
;;;Übergeben wird der relative Pfad, der hinter den Windows-Pfad angehängt wird. Wenn die Verzeichnisse nicht vorhanden sind werden sie erstellt.
(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))

;;;Bessere Version
(defun JBf_list:nth:change(liste EintragNew pos / n )
  (setq n -1)
  (mapcar '(lambda (A)
             (setq n (+ n 1))
             (if (= n pos)
               EintragNew
               A))liste))



;;;--------------------------------------------------------------------------------------------------------
;;;allgemeine 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" sab 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 (JBfd_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))
										   (JBfd_AcadSystem:TrustedPath:Split TrustedPaths)))))))
  )

;;;String splitten an Semikolons, als Liste zurückgeben
(defun JBfd_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
  )

;;;DCL-Liste komplett neu füllen
(defun JBf_Dcl:AddList:New (key liste / )
  (start_list key 3)
  (mapcar 'add_list liste)
  (end_list)
  )
;;;--------------------------------------------------------------------------------------------------------
;;;allgemeine Funktionen => Layer, Farbe							   	   
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

;;;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:Name (itoa (abs aci))))));;;Ini-VlaList



  (defun JBf_layer:Aci:Get:Name(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 farbnr)))
  

  
(defun JBf_TrueColor:vlaList:Ini ( / )
  '(("Blue" . nil)
    ("BookName" . nil)
    ("ColorIndex" . nil)
    ("ColorMethod" . nil)
    ("ColorName" . nil)
    ("EntityColor" . nil)
    ("Green" . nil)
    ("Red" . nil)))
  
  ;;;##### 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)


  
;;;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)))))))




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

(princ (strcat
          "\n|++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++|"
          "\n|Farbmerker pro Layer.                                       |"
          "\n|------------------------------------------------------------|"
          "\n|erstellt durch Bosse-engineering - www.bosse-engineering.com|"
          "\n|------------------------------------------------------------|"
          "\n|Befehlszeilenaufruf: FMK                                    |"
          "\n|++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++|"
          )
       )
(princ)


