
;;;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: BOR - Es werden aus auszuwählenden Blockdefinitionen Objekte gelöscht. Um die Objekte auszu-
;;;wählen werden alle Objekte aus der aktuellen Blockdefinitionsauswahl angeboten, verfeinert werden kann  
;;;die Liste über Layer- und Farbfilter.								   
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;;;globale Variablen:										   	   
;;;- JB_BOR$DCL$_[x]_po (Positionen der Dialogfenster)							   
;;;- JB_BOR_$DCL$_File (temporäre DCL-Datei)								   
;;;                                                                              Jörn Bosse, 14.02.23	   
;;;--------------------------------------------------------------------------------------------------------



;;;aufrufenden Funktionen
(defun c:BOR ( / )
  (JB_BOR)
  )

;;;Intro
(defun JB_BOR:Intro (str / )
  (princ "\nerstellt durch Bosse-engineering - www.bosse-engineering.com\n")
  (princ "\n----------------------BOR(1.0), 14.02.23---------------------")
  (princ str)
  (princ "\n-------------------------------------------------------------")
  )


;;;Liste mit Kategorien, Werte können an dieser Stelle ergänzt bzw. geändert werden

;;;Variablenliste
(defun JB_BOR:v_liste ( / )
  
  '(
     ( "DboxSettings" . (
                         ( "Dbox1" .
                            (
                             ( "JB_1_l1" . nil);;;BlocknameListe
			     ( "JB_1_r1-2" . 0);;;Radio: 0 = Filter, 1 = aus CAD
                             ( "JB_1_t1" . "*");;;Filterwert
                             ( "JB_1_to1" . "0");;;Filter Layer
                             ( "JB_1_to2" . "0");;;Filter Farben
                             ( "JB_1_l2" . nil);;;ObjektListe
                             ))
                         ( "Dbox3" .
                            (
                             ( "JB_3_t1" . "*");;;Filterwert für Layer
                             ))
                         ))))
;;;Pfad für SIC-Datei in Windows-User
(defun JB_BOR: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 
                           )"BOR_sic.lsp")  ;;;getauscht, z.B. c:\\User\\[WindowsUsername]\\LispData\\acad\\
  )

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

  (setq pfad_ini (JB_BOR: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_BOR:v_liste))pfad_ini nil))
  
  (vla-startundomark (vla-get-activedocument(vlax-get-acad-object)))
  (JBf_init
    '(("CMDECHO" 0)
      ("DIMZIN" 3)
      ))
  
  
  (JB_BOR:Intro "\nBOR: Block-Objekte löschen oder ändern.")

  
  

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

  (JB_BOR: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_BOR:v_liste:DboxSettings:get (key v_liste / )
  (cdr(assoc key(cdr (assoc "DboxSettings" v_liste))))
)


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


;;;ÜBersetzungsliste für Objekte nach Deutsch
(defun JB_BOR:DBox1:Objnames:Translate  (vla-Objectname /)
  (cond
    ((= vla-Objectname "AcDbFace") "3D-Fläche")
    ((= vla-Objectname "AcDb3DPolyline") "3D-Polylinie")
    ((= vla-Objectname "AcDbSolid") "Körper")
    ((= vla-Objectname "AcDbArc") "Bogen")
    ((= vla-Objectname "AcDbAttributeDefinition") "Attribut")
    ((= vla-Objectname "AcDbBlockReference") "Blockreferenz-XRef")
    ((= vla-Objectname "AcDbCircle") "Kreis")
    ((= vla-Objectname "AcDbRotatedDimension") "Gedrehte Bemaßung")
    ((= vla-Objectname "AcDbAlignedDimension") "Ausgerichtete Bemaßung")
    ((= vla-Objectname "AcDbArcDimension") "Bogenlängenbemaßung")
    ((= vla-Objectname "AcDbOrdinateDimension") "Koordinatenbemaßung")
    ((= vla-Objectname "AcDbRadialDimension") "Radialbemaßung")
    ((= vla-Objectname "AcDbRadialDimensionLarge") "Verkürzte Bemaßung")
    ((= vla-Objectname "AcDbDiametricDimension") "Diametral")
    ((= vla-Objectname "AcDb3PointAngularDimension")"3-Punkt-Winkelbemaßung")
    ((= vla-Objectname "AcDb2LineAngularDimension") "Winkelbemaßung")
    ((= vla-Objectname "AcDbEllipse") "Ellipse")
    ((= vla-Objectname "AcDbHatch") "Schraffur")
    ((= vla-Objectname "AcDbLeader") "Führung")
    ((= vla-Objectname "AcDbLine") "Linie")
    ((= vla-Objectname "AcDbMLeader") "Multi-Führungslinie")
    ((= vla-Objectname "AcDbMline") "MLinie")
    ((= vla-Objectname "AcDbMText") "MText")
    ((= vla-Objectname "AcDbPoint") "Punkt")
    ((= vla-Objectname "AcDbSubDMesh") "Netz")
    ((= vla-Objectname "AcDbPolygonMesh") "Polygonnetz")
    ((= vla-Objectname "AcDbPolyFaceMesh") "Vielflächennetz")
    ((= vla-Objectname "AcDbPolyline") "Polylinie")
    ((= vla-Objectname "AcDbRasterImage") "Pixelbild")
    ((= vla-Objectname "AcDbRay") "Strahl")
    ((= vla-Objectname "AcDbRegion") "Region")
    ((= vla-Objectname "AcDbShape") "Symbol")
    ((= vla-Objectname "AcDbSpline") "Spline")
    ((= vla-Objectname "AcDbTable") "Tabelle")
    ((= vla-Objectname "AcDbText") "Text")
    ((= vla-Objectname "AcDbFcf") "Toleranz")
    ((= vla-Objectname "AcDbTrace") "Band")
    ((= vla-Objectname "AcDbXline") "KLinie")
    ((= vla-Objectname "AcDb3dSolid") "3D-Volumenkörper")
    ((= vla-Objectname "AcDbHelix") "Spirale")
    ((= vla-Objectname "AcDbPlaneSurface") "Fläche-Planar")
    ((= vla-Objectname "AcDbOle2Frame") "Ole")
    ((= vla-Objectname "AcDbMInsertBlock") "Meinfüg-Block")
    ((= vla-Objectname "AcDbAttributeReference") "Attribut")
    ('T vla-Objectname)))


        

;;;Blockdefionitionen - NameList
(defun JB_BOR:Dbox1:l1 ( / RETLIST)
  (vlax-for ITEM(vla-get-blocks(vla-get-activedocument (vlax-get-acad-object)))
    (if (and(=(vla-get-IsXref ITEM):vlax-false)
            (=(vla-get-IsLayout ITEM):vlax-false)
            (not(vl-string-search "*"(vla-get-name ITEM))))
      
      (setq RetList (cons (vla-get-name ITEM)RetList))
      )
    )
  (setq l1&Dbox1(vl-sort RetList '(lambda(e1 e2)(< e1 e2))))
  )

;;;Blockdefinitionen - NameList reduziert
(defun JB_BOR:Dbox1:BlockNameList:l1WorX ( / X)
  (setq l1WorX&Dbox1
         (vl-remove-if 'not
           (mapcar '(lambda(X)
                      (if (= (cdr(assoc "JB_1_r1-2" Settings&Dbox1))0)
                        (if (wcmatch (strcase X)(strcase (cdr(assoc "JB_1_t1" Settings&Dbox1))))
                          X)
                        X)
                      )
             l1&Dbox1)
           )
        )
  )

;;;Auswahl in Liste
(defun JB_BOR:Dbox1:BlockNameList:l1Sel ( / N X)
  (setq l1_sel&Dbox1 nil)
  (setq n -1)
  (if (cdr(assoc "JB_1_l1" Settings&Dbox1))
    (mapcar '(lambda(X)
               (setq n (+ n 1))
               (if (member (strcase X)(cdr(assoc "JB_1_l1" Settings&Dbox1)))
                 (setq l1_sel&Dbox1 (cons n l1_sel&Dbox1))
                 )
               )
      l1WorX&Dbox1)
    )
  (setq l1_sel&Dbox1 (vl-sort l1_sel&Dbox1 '(lambda(e1 e2)(< e1 e2))))
  (if (not l1_sel&Dbox1)
    (if l1WorX&Dbox1
      (setq l1_sel&Dbox1 '(0)))
    )
  )

;;;TrueColor-Objekt in String zurückgeben
(defun JB_BOR:Dbox1:l2:vla-TrueColor->String (vla-Blockobj / vla-TrueColor)
  (setq vla-TrueColor (vla-get-TrueColor vla-Blockobj))
  (cond ((=(vla-get-ColorMethod vla-TrueColor)193);;;ByBlock
        "VonBlock")
	((=(vla-get-ColorMethod vla-TrueColor)192);;;ByLayer
	 "VonLayer")
	((=(vla-get-ColorMethod vla-TrueColor)195);;;ACI
	 (strcat "ACI=" (itoa(vla-get-color vla-Blockobj))))
	((=(vla-get-ColorMethod vla-TrueColor)194);;;RGB/Farbbuch
         (if (/=(vla-get-Bookname vla-TrueColor)"")
           (strcat (vla-get-Bookname vla-TrueColor)"/"(vla-get-Colorname vla-TrueColor))
         (strcat "R=" (itoa(vla-get-Red vla-TrueColor))" G="(itoa(vla-get-Green vla-TrueColor))" B="(itoa(vla-get-Blue vla-TrueColor))))
	 )
        )
  )
      
;;;Liste 2 mit BlockObjekten
(defun JB_BOR:Dbox1:l2 ( / L1_SEL RETLIST STRINGKEY VLA-BLOCKOBJ)
  (mapcar '(lambda(l1_sel)
             (vlax-for vla-Blockobj(vla-item(vla-get-blocks(vla-get-activedocument(vlax-get-acad-object)))(nth l1_sel l1WorX&Dbox1))
               (setq StringKey
                      (strcat
                        (vla-get-Objectname vla-Blockobj)
                        (if (=(cdr(assoc "JB_1_to1" Settings&Dbox1))"1")
                          (vla-get-layer vla-Blockobj)
                          "*")
                        (if (=(cdr(assoc "JB_1_to2" Settings&Dbox1))"1")
                          (JB_BOR:Dbox1:l2:vla-TrueColor->String vla-Blockobj)
                          "*")
                        ))
               (if (not (assoc StringKey RetList))
                 (setq RetList (append RetList (list (list StringKey (list vla-Blockobj)))))
                 (setq RetList (subst (list StringKey (cons vla-Blockobj (cadr (assoc StringKey RetList))))(assoc StringKey RetList)RetList))
                 )
               )
             )
    l1_sel&Dbox1)
  (setq l2&Dbox1 (vl-sort RetList (function(lambda(e1 e2)(< (JB_BOR:DBox1:Objnames:Translate(vla-get-Objectname(car(cadr e1))))(JB_BOR:DBox1:Objnames:Translate(vla-get-Objectname(car(cadr e2)))))))))
  )
  
  
;;;DBox 1
(defun JB_BOR:Dbox1 (v_liste pfad_ini / DCLID OK PinList&DBox1 l1&Dbox1 l1WorX&Dbox1 l1_sel&Dbox1 l2&Dbox1 l2_sel&Dbox1 Layername vla-TrueColor Done)
  (setq Settings&Dbox1 (JB_BOR:v_liste:DboxSettings:get "Dbox1" v_liste))
  (JB_BOR:Dbox1:l1)
  (JB_BOR:Dbox1:BlockNameList:l1WorX)
  (JB_BOR:Dbox1:BlockNameList:l1Sel)
  
  
    
  (while (not (member ok '(99)))

    (setq DclId (JBf_Dcl:Load_dialog JB_BOR_$DCL$_File "JB_BOR_1" JB_BOR$DCL$_1_po))
    
    (JB_BOR:Dbox1:l2)
    (if l2&Dbox1 (setq l2_sel&Dbox1 '(0))(setq l2_sel&Dbox1 nil))
    (JB_BOR:Dbox1:set)
    (JB_BOR:Dbox1:mode)
    
    
    (mapcar '(lambda (A) (action_tile A (strcat "(JB_BOR:Dbox1:action \"" A "\")")))
            '("JB_1_b1"  "JB_1_b2" "JB_1_b3" "JB_1_b4"
              "JB_1_l1"
              "JB_1_l2"
              "JB_1_r1" "JB_1_r2"
              "JB_1_to1" "JB_1_to2"
	      "accept" "cancel"
             )
    )
    (setq ok (start_dialog))
    (unload_dialog DclId)
    
    (cond ((= ok 99) ;;;Ende
           (setq v_liste (JB_BOR:v_liste:DboxSettings:put "Dbox1" Settings&dbox1 v_liste))
           (JBf_SIC:sichern v_liste pfad_ini nil)
           )
          ((= ok 102);;;Blockreferenzen aus CAD
           (JB_BOR:Dbox1:action:b2)
           )
          ((= ok 103);;;Farbe ändern
           (setq vla-TrueColor(JB_BOR:Dbox1:vla-TrueColor)                 
                 Done (cadr vla-TrueColor)
                 vla-TrueColor (car vla-TrueColor))
                 
           (if done
             (JB_BOR:DBox1:Done vla-TrueColor nil)
             )
           )
          ((= ok 104);;;Layer ändern
           (setq v_liste(JB_BOR:Dbox3 v_liste)                 
                 Done (cadr v_liste)
                 Layername (caddr v_liste)
                 v_liste (car v_liste))
           (if done
             (JB_BOR:DBox1:Done nil Layername)
             
             )
               
           )
          
          ((= ok 1);;;Objekte löschen
           (JB_BOR:DBox1:Done nil nil)
           )
          )
    ) 
  )


;;;Blockreferenzen updaten
(defun JB_BOR:DBox1:BlockRef:Update ( / AWS L1_SEL N)
  (mapcar '(lambda(l1_sel)
             (if (setq aws (ssget "_X" (list (cons 0 "INSERT")(cons 2 (nth l1_sel l1WorX&Dbox1)))))
               (progn
                 (setq n 0)
                 (repeat (sslength aws)
                   (vla-update (vlax-ename->vla-object(ssname aws n)))
                   (setq n (+ n 1))
                   )
                 )
               )
             )
    l1_sel&Dbox1)
  )
    


;;;Farbe wählen
(defun JB_BOR:Dbox1:vla-TrueColor ( / GCLIST VLA-OBJ VLA-TRUECOLOR VLALIST)
  (if (and l2_sel&Dbox1 l2&Dbox1
           (setq vla-obj (car(cadr(nth (car l2_sel&Dbox1)l2&Dbox1))))
           (setq vla-TrueColor (vla-get-TrueColor vla-obj))
           (setq vlaList(JB_TrueColor:TrueColorObj->get2vlaList vla-TrueColor))
           (setq GcList (JBf_TrueColor:vlaList->gcList vlaList))
           (setq gcList (JB_TrueColor:get gcList)))
    (progn
      (JB_TrueColor:putByGcList->TrueColorObj gcList vla-TrueColor)
      (list vla-TrueColor 'T))
    (list nil nil))
  )


;;;Action: Blockreferenzen aus CAD auswählen
(defun JB_BOR:Dbox1:action:b2 ( / AWS N NAME RETLIST)
  (if (and(princ "\nWählen Sie Blockreferenzen:")
          (setq aws (ssget (list (cons 0 "INSERT")))))
    (progn
      (setq n 0)
      (repeat (sslength aws)
        (setq name(vla-get-Effectivename(vlax-ename->vla-object (ssname aws n))))
        (if (not(member name RetList))
          (setq RetList (cons name RetList)))
        (setq n (+ n 1))
        )
      (setq RetList (vl-sort RetList '(lambda(e1 e2)(< e1 e2))))
      (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 "*" "JB_1_t1"))
      (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 (mapcar 'strcase RetList)"JB_1_l1"))
      (JB_BOR:Dbox1:BlockNameList:l1WorX)
      (JB_BOR:Dbox1:BlockNameList:l1Sel)
      )
    )
  )


;;;Objekte wieder aus  Blockreferenzen entfernen
(defun JB_BOR:Dbox1:action:b3 ( / ITEM LOGLIST X)
  (mapcar '(lambda(X)
             (vlax-for ITEM (vla-item(vla-get-blocks
                                       (vla-get-activedocument(vlax-get-acad-object)))
                              (nth X l1WorX&Dbox1))
               (if (=(JBf_list_xdaten_read:Vla "JB_OBT" ITEM 1000)"OBT")
                 (progn
                   (vla-delete ITEM)
                   (setq LogList (cons (nth X l1WorX&Dbox1)LogList))
                   )
                 )
               )
             )
    l1_sel&Dbox1)
  (if LogList
    (progn
      (vla-regen (vla-get-activedocument(vlax-get-acad-object)) acActiveViewport)
      (alert (strcat "Die \"OBT\"-Objekte wurden in folgenden Blockdefinitionen entfernt:\n"
               (apply 'strcat
                      (mapcar '(lambda(X)
                                 (strcat "\n- " X))
                        (reverse LogList)))))
      )
    )
  )
  
      
      


;;;Action b1: Filterwert
(defun JB_BOR:Dbox1:action:b1 ( / WERT)
  (if (setq wert (JB_BOR:Dbox2 (cdr(assoc "JB_1_t1" Settings&dbox1))))
    (progn
      (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 wert "JB_1_t1"))
      (JB_BOR:Dbox1:BlockNameList:l1WorX)
      (setq Settings&dbox1(JBf_list:subst:gc Settings&dbox1(mapcar 'strcase l1WorX&Dbox1)"JB_1_l1"))
      (JB_BOR:Dbox1:BlockNameList:l1Sel)
      (JB_BOR:Dbox1:l2)
      (if l2&Dbox1 (setq l2_sel&Dbox1 '(0))(setq l2_sel&Dbox1 nil))
      (JB_BOR:Dbox1:set)
      (JB_BOR:Dbox1:mode)
      )
    )
  )

;;;Auswahl in Liste => der aktuelle Filter oder die Auswahl über Blockreferenzen bleibt erhalten
(defun JB_BOR:Dbox1:action:l1 ( / )
  (setq l1_sel&Dbox1 (mapcar 'atoi(JBf_String:Delimiter->List $value " ")))
  (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 (mapcar '(lambda(X)(strcase(nth X l1WorX&Dbox1)))l1_sel&Dbox1)"JB_1_l1"))
  (JB_BOR:Dbox1:l2)
     (if l2&Dbox1 (setq l2_sel&Dbox1 '(0))(setq l2_sel&Dbox1 nil))
     (JB_BOR:Dbox1:set)
     (JB_BOR:Dbox1:mode)
  )
          
;;;Action (Variable global in Aufrufender Funktion)
(defun JB_BOR:Dbox1:action (key / NAME X)

  (cond
    ((= key "JB_1_r1")
     (setq Settings&Dbox1 (JBf_list:subst:gc Settings&Dbox1 (- 1 (atoi $value))"JB_1_r1-2"))
     (JB_BOR:Dbox1:BlockNameList:l1WorX)
     (JB_BOR:Dbox1:BlockNameList:l1Sel)
     (JB_BOR:Dbox1:l2)
     (if l2&Dbox1 (setq l2_sel&Dbox1 '(0))(setq l2_sel&Dbox1 nil))
     (JB_BOR:Dbox1:set)
     (JB_BOR:Dbox1:mode)
     
     )
    ((= key "JB_1_r2")
     (setq Settings&Dbox1 (JBf_list:subst:gc Settings&Dbox1 (atoi $value)"JB_1_r1-2"))
     (JB_BOR:Dbox1:BlockNameList:l1WorX)
     (JB_BOR:Dbox1:BlockNameList:l1Sel)
     (JB_BOR:Dbox1:l2)
     (if l2&Dbox1 (setq l2_sel&Dbox1 '(0))(setq l2_sel&Dbox1 nil))
     (JB_BOR:Dbox1:set)
     (JB_BOR:Dbox1:mode)
     )
    ((= key "JB_1_to1")
     (setq Settings&Dbox1 (JBf_list:subst:gc Settings&Dbox1 $value "JB_1_to1"))
     (JB_BOR:Dbox1:l2)
     (if l2&Dbox1 (setq l2_sel&Dbox1 '(0))(setq l2_sel&Dbox1 nil))
     (JB_BOR:Dbox1:set)
     (JB_BOR:Dbox1:mode)
     )
    ((= key "JB_1_to2")
     (setq Settings&Dbox1 (JBf_list:subst:gc Settings&Dbox1 $value "JB_1_to2"))
     (JB_BOR:Dbox1:l2)
     (if l2&Dbox1 (setq l2_sel&Dbox1 '(0))(setq l2_sel&Dbox1 nil))
     (JB_BOR:Dbox1:set)
     (JB_BOR:Dbox1:mode)
     )
    ((= key "JB_1_l1");;;Listenauswahl 1
     (JB_BOR:Dbox1:action:l1)
     )
    ((= key "JB_1_l2");;;Listenauswahl 2
     (setq l2_sel&Dbox1 (mapcar 'atoi(JBf_String:Delimiter->List $value " ")))
     )
    ((= key "JB_1_b1")    ;;;Filterwert
     (JB_BOR:Dbox1:action:b1)
     )
    ((= key "JB_1_b2")    ;;;Blockreferenzen aus CAD
     (setq JB_BOR$DCL$_1_po (done_dialog 102))
     )
    ((= key "JB_1_b4")    ;;;Layer ändern
     (setq JB_BOR$DCL$_1_po (done_dialog 104))
     )
    ((= key "JB_1_b3")    ;;;Farbe ändern
     (setq JB_BOR$DCL$_1_po (done_dialog 103))
     )
    ((= key "accept") ;;;Objekte löschen
     (setq JB_BOR$DCL$_1_po (done_dialog 1))
     )

    ((= key "cancel") ;;;Ende     
     (setq JB_BOR$DCL$_1_po (done_dialog 99))
     )
    )
)


    
;;;DBox1: setten
(defun JB_BOR:Dbox1:set ( / X)
  
  (start_list "JB_1_l1" 3)
  (mapcar 'add_list l1WorX&Dbox1)
  (end_list)
  (if l1_sel&Dbox1
    (progn
      (set_tile "JB_1_l1" "")
      (set_tile "JB_1_l1" (vl-string-right-trim " "(apply 'strcat(mapcar '(lambda(X)(strcat (itoa X) " "))l1_sel&Dbox1))))
      )
    (set_tile "JB_1_l1" "")
    )

  (start_list "JB_1_l2" 3)
  (mapcar 'add_list (mapcar '(lambda(X)
                               (strcat (JB_BOR:DBox1:Objnames:Translate(vla-get-Objectname(car(cadr X)))) "(" (itoa(length(cadr X)))")\t"
                                 (if (=(cdr(assoc "JB_1_to1" Settings&Dbox1))"1")
                                   (strcat " Layer: " (vla-get-layer (car(cadr X))))"")
                                 (if (=(cdr(assoc "JB_1_to2" Settings&Dbox1))"1")
                                   (strcat " Farbe: " (JB_BOR:Dbox1:l2:vla-TrueColor->String (car(cadr X))))"")))
                      l2&Dbox1))
  (end_list)
  (if l2_sel&Dbox1
    (progn
      (set_tile "JB_1_l2" "")
      (set_tile "JB_1_l2" (vl-string-right-trim " "(apply 'strcat(mapcar '(lambda(X)(strcat (itoa X) " "))l2_sel&Dbox1))))
      )
    (set_tile "JB_1_l2" "")
    )
  
  (mapcar '(lambda(X)
             (set_tile (strcat "JB_1_"(car X))(cadr X)))
    (list
      (list "t1" (cdr(assoc "JB_1_t1" Settings&dbox1)))
      (list "r1" (itoa(- 1 (cdr(assoc "JB_1_r1-2" Settings&dbox1)))))
      (list "r2" (itoa(cdr(assoc "JB_1_r1-2" Settings&dbox1))))
      (list "to1" (cdr(assoc "JB_1_to1" Settings&dbox1)))
      (list "to2" (cdr(assoc "JB_1_to2" Settings&dbox1)))
           
      )
    )
  )
;;;DBox1, moden
(defun JB_BOR:Dbox1:mode ( / )
  (if (not l1WorX&Dbox1)
    (progn
      (mode_tile "JB_1_l1" 1)
      (mode_tile "JB_1_l2" 1)
      (mode_tile "JB_1_to1" 1)
      (mode_tile "JB_1_to2" 1)
      (mode_tile "accept" 1)
      (alert "Es ist noch keine Blockdefinion ausgewählt."))
    (progn
      (mode_tile "JB_1_l1" 0)
      (mode_tile "JB_1_l2" 0)
      (mode_tile "JB_1_to1" 0)
      (mode_tile "JB_1_to2" 0)
      (mode_tile "accept" 0)
      )
    )

  (if (=(cdr(assoc "JB_1_r1-2" Settings&dbox1))0)
    (progn
      (mode_tile "JB_1_t1" 0)
      (mode_tile "JB_1_b1" 0)
      (mode_tile "JB_1_b2" 1))
    (progn
      (mode_tile "JB_1_t1" 1)
      (mode_tile "JB_1_b1" 1)
      (mode_tile "JB_1_b2" 0))
    )
  )



;;;Objekte löschen, FArbe ändern oder Layer
(defun JB_BOR:DBox1:Done (vla-TrueColor LayerName / L2_SEL MSGFLAG VLA-BLOCKOBJ)
  (mapcar '(lambda(l2_sel)
             (mapcar '(lambda(vla-Blockobj)
                        (if (= (vla-get-Objectname vla-Blockobj)"AcDbAttributeDefinition")
                          (setq msgFlag 'T))
                        (cond (vla-TrueColor
                               (vla-put-TrueColor vla-Blockobj vla-TrueColor)
                               )
                              (LayerName
                               (vla-put-layer vla-Blockobj LayerName)
                               )
                              ('T
                               (vla-delete vla-Blockobj))
                              )
                        
                        )
               (cadr(nth l2_sel l2&Dbox1)))
             )
    l2_sel&Dbox1)
  (JB_BOR:DBox1:BlockRef:Update)
  (if msgFlag
    (cond (vla-TrueColor
           (alert "Es wurden Farben bei Attribut-Definitionen geändert, verwendent Sie den Befehl \"ATTSYNC\", wenn die zugehörigen Blockreferenzen angepasst werden sollen.")
           )
          (LayerName
           (alert "Es wurde der Layername bei Attribut-Definitionen geändert, verwendent Sie den Befehl \"ATTSYNC\", wenn die zugehörigen Blockreferenzen angepasst werden sollen.")
           )
          ('T
           (alert "Es wurden Attribut-Definitionen gelöscht, verwendent Sie den Befehl \"ATTSYNC\", wenn die zugehörigen Blockreferenzen angepasst werden sollen."))
          )
    )
  )
   
;;;DBox2 => Filterwert
(defun JB_BOR:Dbox2 (wert&Dbox2 / DCLID OK )
     
  (while (not (member ok '(1 99)))

    (setq DclId (JBf_Dcl:Load_dialog JB_BOR_$DCL$_File "JB_BOR_2" JB_BOR$DCL$_2_po))

    (set_tile "JB_2_e1" wert&Dbox2)
    (mode_tile "JB_2_e1" 2)
    
    (mapcar '(lambda (A) (action_tile A (strcat "(JB_BOR:Dbox2:action \"" A "\")")))
            '(
	      "accept"
	      "cancel"
	      
             )
    )

    (setq ok (start_dialog))
    (unload_dialog DclId)

    (if(and(= ok 1)(= wert&Dbox2 ""))
      (setq wert&Dbox2 "*")            
      )    
    )
  (if (= ok 1)
    wert&Dbox2)
  )

;;;Action (Variable global in Aufrufender Funktion)
(defun JB_BOR:Dbox2:action (key / )
  (cond
    ((= key "accept")    ;;;OK
     (setq wert&Dbox2 (vl-string-subst "." ","(get_tile "JB_2_e1")))
     (setq JB_BOR$DCL$_2_po (done_dialog 1)))
    ((= key "cancel")    ;;;Ende
     (setq JB_BOR$DCL$_2_po (done_dialog 99))) 
  )
)

;;;DBox3, LAyerListe
(defun JB_BOR:Dbox3:LayerList ( / RETLIST)
  (vlax-for ITEM(vla-get-layers(vla-get-activedocument (vlax-get-acad-object)))
    (setq RetList (cons (vla-get-name ITEM)RetList))
    )
  (setq LayerList&Dbox3(vl-sort RetList '(lambda(e1 e2)(< e1 e2))))
  (setq LayerListWorX&Dbox3 (vl-remove-if '(lambda(X)(not(wcmatch (strcase X) (strcase(cdr(assoc "JB_3_t1" Settings&Dbox3))))))LayerList&Dbox3))
  )

;;;DBox3, LayerFirstSelect
(defun JB_BOR:Dbox3:LayerFirstSel ( / LAYERFIRSTOBJ)
  (setq LayerFirstObj(vla-get-layer(car(cadr(nth (car l2_sel&Dbox1)l2&Dbox1)))))
  (if (member (strcase LayerFirstObj)(mapcar 'strcase LayerListWorX&Dbox3))
    (setq l1_sel&Dbox3 (itoa(-(length LayerListWorX&Dbox3)(length(member (strcase LayerFirstObj)(mapcar 'strcase LayerListWorX&Dbox3))))))
    (if LayerListWorX&Dbox3
      (setq l1_sel&Dbox3 "0")
      (setq l1_sel&Dbox3 nil)
      )
    )
  )

;;;DBox3, setten
(defun JB_BOR:Dbox3:set ( / )
  (start_list "JB_3_l1" 3)
  (mapcar 'add_list LayerListWorX&Dbox3)
  (end_list)
  (if l1_sel&Dbox3
    (set_tile "JB_3_l1" l1_sel&Dbox3)
    (set_tile "JB_3_l1" "")
    )

  (set_tile "JB_3_t1" (cdr(assoc "JB_3_t1" Settings&Dbox3)))
  )

;;;DBox3, moden
(defun JB_BOR:Dbox3:mode ( / )
  (if (not l1_sel&Dbox3)
    (progn
      (mode_tile "JB_3_b1" 2)
      (mode_tile "accept" 1)
      (alert "Der eingestellte Layerfilter passt auf keinen der vorhandenen Layer in der Zeichnung.")
      )
    (progn
      (mode_tile "JB_3_l1" 2)
      (mode_tile "accept" 0)
      )
    )
  )

;;;DBox3 => Layername
(defun JB_BOR:Dbox3 (v_liste / DCLID OK Settings&Dbox3 LayerList&Dbox3 LayerListWorX&Dbox3 l1_sel&Dbox3 LayerName)
  (setq Settings&Dbox3 (JB_BOR:v_liste:DboxSettings:get "Dbox3" v_liste))
  (JB_BOR:Dbox3:LayerList)
  (JB_BOR:Dbox3:LayerFirstSel)
  
   
  (while (not (member ok '(1 99)))

    (setq DclId (JBf_Dcl:Load_dialog JB_BOR_$DCL$_File "JB_BOR_3" JB_BOR$DCL$_3_po))

    (JB_BOR:Dbox3:set)
    (JB_BOR:Dbox3:mode)
    
    (mapcar '(lambda (A) (action_tile A (strcat "(JB_BOR:Dbox3:action \"" A "\")")))
            '(
              "JB_3_l1"
              "JB_3_b1"
	      "accept"
	      "cancel"
	      
             )
    )

    (setq ok (start_dialog))
    (unload_dialog DclId)
   
      
    )
  (if(= ok 1)
      (progn
        (setq LayerName (nth (atoi l1_sel&Dbox3) LayerListWorX&Dbox3))
        (setq v_liste (JB_BOR:v_liste:DboxSettings:put "Dbox3" Settings&dbox3 v_liste))
        (list v_liste 'T LayerName)
        )
      (list v_liste nil nil)
      )
  )

(defun JB_BOR:Dbox3:action (key / )
  (cond ((= key "JB_3_l1")
         (setq l1_sel&Dbox3  $value)
         (if (= $reason 4)
           (setq JB_BOR$DCL$_3_po (done_dialog 1))
           )
         )
        ((= key "JB_3_b1")
         (if(setq wert (JB_BOR:Dbox2 (cdr(assoc "JB_3_t1" Settings&dbox3))))
           (progn
             (setq Settings&dbox3 (JBf_list:subst:gc Settings&dbox3 (if (= wert "")"*" wert)"JB_3_t1"))
             (JB_BOR:Dbox3:LayerList)
             (JB_BOR:Dbox3:LayerFirstSel)
             (JB_BOR:Dbox3:set)
             (JB_BOR:Dbox3:mode)
             )
           )
         )
        ((= key "accept")
         (setq JB_BOR$DCL$_3_po (done_dialog 1))
         )
        ((= key "cancel")
         (setq JB_BOR$DCL$_3_po (done_dialog 99))
         )
        )
  )
         
;;;DCL-schreiben
(defun JB_BOR:dcl:Write ( / file)  
  (if (and (setq JB_BOR_$DCL$_File (vl-filename-mktemp (strcat "BOR.dcl")))
           (setq file (open JB_BOR_$DCL$_File "w"))
      )
    (progn
      (mapcar '(lambda (A)
                       (write-line A file)
               )
              (mapcar '(lambda (A)
                               (strcat "\n" A)
                       )
              (list
                "JB_BOR_1: dialog {label = \"Block-Objekte löschen oder ändern\";"
                ":boxed_column {label = \"Blockdefinitionen\";"
                ":list_box {key = \"JB_1_l1\"; label = \"Mehrfachauswahl mit STRG+UMSCHALT\";multiple_select = true;}"
                ":row{"
                ":radio_column{"
                ":radio_button {key = \"JB_1_r1\"; label = \"Filter\";}"
                ":radio_button {key = \"JB_1_r2\"; label = \"von Blockreferenzen\";}}"
                ":column{"
                ":text {key = \"JB_1_t1\"; label = \"MeinFilter\"; width = 10;}"
                "}"
                ":column {"
                ":button {key = \"JB_1_b1\"; label = \"&Filterwert...\";}"
                ":button {key = \"JB_1_b2\"; label = \"aus &CAD<\";}"
                "}"
                "}"
                "}"
                ":boxed_column {label = \"Objektliste zum Löschen oder Ändern\";"
                ":list_box {key = \"JB_1_l2\"; label = \"Mehrfachauswahl mit STRG+UMSCHALT\"; multiple_select = true; tabs = \"20\";width = 65;}"
                ":boxed_column {label = \"Filter\";"
                ":toggle {key = \"JB_1_to1\"; label = \"Layer\";}"
                ":toggle {key = \"JB_1_to2\"; label = \"Farbe\";}"
                "}"
                "}"
                ":row{fixed_width = true;alignment = centered;"
                ":retirement_button {label = \"Objekte &Löschen\"; key= \"accept\";is_default = true; fixed_width=true;}"                
                ":spacer {width = 2;}"
                ":button {key = \"JB_1_b4\"; label = \"L&ayer ändern...\";}"
                ":spacer {width = 2;}"
                ":button {key = \"JB_1_b3\"; label = \"Far&be ändern...\";}"
                ":retirement_button {label = \"&Ende\"; key= \"cancel\";is_cancel = true; fixed_width=true;}"
                "}}"
                "JB_BOR_2: dialog {label = \"Filterwert\";"
                ":boxed_column {label = \"bitte eingeben\";"
                ":edit_box {key = \"JB_2_e1\"; allow_accept = true;}"
                "}"
                "ok_cancel;}"
                "JB_BOR_3: dialog {label = \"Layer ändern\";"
                ":boxed_column {label = \"bitte auswählen\";"
                ":list_box {key = \"JB_3_l1\"; width = 50; height = 20;label = \"Layer\";}"
                ":row{"
                ":button {key = \"JB_3_b1\"; label = \"&Filter...\"; fixed_width=true;}"
                ":text {key = \"JB_3_t1\"; label = \"MeinLayer\"; width = 40;}"
                "}"
                "}"
                "ok_cancel;}"


               )
              )
      )
      (close file)
      JB_BOR_$DCL$_File
    )
  )
)


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

;;;Es wird ein String anhand eines Trennzeichens zerlegt, wenn das trennzeichen doppelt vorkommt, dann wird ein Leerzeichen als Zwischenraum zurückgegeben
(defun JBf_string:Trennzeichen->listCharsWithBlanks (str str_trenn / A RETLIST SUB TABN)
  (setq str_trenn (car(vl-string->list str_trenn)))
  (mapcar '(lambda(A)
             (if (/= A str_trenn)
               (setq sub (cons A sub)
                     TabN nil)
               (progn
                 (setq TabN (if (not TabN) 1 (+ TabN 1)))
                 (if (= TabN 1)
                   (setq RetList (cons (reverse sub)RetList)
                         sub nil)
                   (setq RetList (cons nil RetList)))))
             )
    (vl-string->list str))
  (if Sub (setq RetList (cons (reverse Sub) RetList)))
  (mapcar '(lambda(A)
             (if A (vl-list->string A)""))(reverse RetList)))

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


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



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

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

;;;RetVal ist wieder eine GcList 62 420 430
(defun JB_TrueColor:get (gcList / )
  (acad_truecolordlg (cond ((cdr(assoc 430 gcList))
			    (assoc 430 gcList))
			   ((cdr(assoc 420 gcList))
			    (assoc 420 gcList))
			   ('T (assoc 62 gcList))))
  )

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


;;;TrueColor aus Objekt und in vlaList zurückgeben
(defun JB_TrueColor:TrueColorObj->get2vlaList (vla-TrueColor / vlaList)
  (setq vlaList(JBf_TrueColor:vlaList:Ini)
	vlaList (JBf_list:subst:gc vlaList (vla-get-Blue vla-TrueColor)"Blue")
	vlaList (JBf_list:subst:gc vlaList (if(/=(vla-get-BookName vla-TrueColor)"")(vla-get-BookName vla-TrueColor))"BookName")
	vlaList (JBf_list:subst:gc vlaList (vla-get-ColorIndex vla-TrueColor)"ColorIndex")
	vlaList (JBf_list:subst:gc vlaList (vla-get-ColorMethod vla-TrueColor)"ColorMethod")
	vlaList (JBf_list:subst:gc vlaList (if(/=(vla-get-ColorName vla-TrueColor)"")(vla-get-ColorName vla-TrueColor))"ColorName")
	vlaList (JBf_list:subst:gc vlaList (vla-get-EntityColor vla-TrueColor)"EntityColor")
	vlaList (JBf_list:subst:gc vlaList (vla-get-Green vla-TrueColor)"Green")
	vlaList (JBf_list:subst:gc vlaList (vla-get-Red vla-TrueColor)"Red")))


;;;#### vla-List -> GcList
(defun JBf_TrueColor:vlaList->gcList (vlaList / RETLIST)
  (cond ((=(cdr(assoc "ColorMethod" vlaList))193);;;ByBlock
	 (setq RetList (list (cons 62 0))))
	((=(cdr(assoc "ColorMethod" vlaList))192);;;ByLayer
	 (setq RetList (list (cons 62 256))))
	((=(cdr(assoc "ColorMethod" vlaList))195);;;ACI
	 (setq RetList (list (cons 62 (boole 1 (cdr(assoc "EntityColor" vlaList)) 255)))))
	((=(cdr(assoc "ColorMethod" vlaList))194);;;RGB/Farbbuch
	 (setq RetList (list (cons 62 (cdr(assoc "ColorIndex" vlaList)))))
	 (setq RetList (cons (cons 420 (- (cdr(assoc "EntityColor" vlaList)) (lsh (boole 9 (cdr(assoc "ColorMethod" vlaList)) 255) 24)))RetList))
	 (if(and (cdr(assoc "BookName" vlaList))(cdr(assoc "ColorName" vlaList)))
	   (setq RetList (cons (cons 430 (strcat(cdr(assoc "BookName" vlaList))"$"(cdr(assoc "ColorName" vlaList))))RetList)))))
  (vl-sort RetList '(lambda(e1 e2)(< (car e1)(car e2)))))


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


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

(princ (strcat
          "\n|++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++|"
          "\n|Block-Objekte löschen oder ändern.                          |"
          "\n|------------------------------------------------------------|"
          "\n|erstellt durch Bosse-engineering - www.bosse-engineering.com|"
          "\n|------------------------------------------------------------|"
          "\n|Befehlszeilenaufruf: BOR                                    |"
          "\n|++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++|"
          )
       )
(princ)

