
;;;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: GTT - Es wird eine Polylinie ausgewählt, damit innerhalb Gitterkreuze erzeugt werden, als   
;;;als Linien oder Blöcke. Die Gitter können entweder im WKS oder BKS erstellt werden.			   
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;;;globale Variablen:										   	   
;;;- JB_GTT$DCL$_[x]_po (Positionen der Dialogfenster)							   
;;;- JB_GTT_$DCL$_File (temporäre DCL-Datei)								   
;;;                                                                              Jörn Bosse, 24.10.23	   
;;;--------------------------------------------------------------------------------------------------------



;;;aufrufenden Funktionen
(defun c:GTT ( / )
  (JB_GTT)
  )

;;;Intro
(defun JB_GTT:Intro (str / )
  (princ "\nerstellt durch Bosse-engineering - www.bosse-engineering.com\n")
  (princ "\n----------------------GTT(1.0), 24.10.23----------------------")
  (princ str)
  (princ "\n--------------------------------------------------------------")
  )




;;;Variablenliste
(defun JB_GTT:v_liste ( / )
  '(
     ( "DboxSettings" . (
                         ( "Dbox1" .
                            (
                             ("JB_1_to1" . "0");;;UCS-Flag (nur wenn BKS aktiv ist)
                             ("JB_1_e1" . 10.0);;;Gitter-Abstand X
                             ("JB_1_to2" . "0");;;Gitter-Abstand Y separat
                             ("JB_1_e2" . 20.0);;;Gitter-Abstand Y
                             ("JB_1_e3" . 0.5);;;GitterLinienlänge
                             ("JB_1_to3" . "0");;;Gitterlinien bis an Polylinie
                             ("JB_1_to4" . "0");;;Gitter als Block
                             ("JB_1_to5" . "0");;;Gitter +1 bei ausgerundeten Polylinien
                             ("JB_1_t1" . ((0 . "LAYER")(100 . "AcDbSymbolTableRecord") (100 . "AcDbLayerTableRecord") (2 . "0") (70 . 0) (62 . 7) (6 . "Continuous") (290 . 1) (370 . -3)));;Layer Entmake Liste
                                                         
                             )
                          )

                         ( "Dbox2" .
                            (
                             ("JB_2_t1" . "*");;;Filter für Layername
                                                                                      
                             )
                          )
                         )
      ))
  )


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

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

  (setq pfad_ini (JB_GTT: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_GTT:v_liste))pfad_ini nil))
  
  (vla-startundomark (vla-get-activedocument(vlax-get-acad-object)))
  (JBf_init
    '(("CMDECHO" 0)
      ("DIMZIN" 3)
      ))
  
  
  (JB_GTT:Intro "\nGTT: Gitterkreuze in Polylinie einfügen.")

  
  

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


  (if (JB_GTT:Bks-WKS:parallel-p)
    (JB_GTT:Dbox1 v_liste pfad_ini)
    )
   
  (princ "\nEnde.")
  (JBf_Reinit)
  (vla-endundomark (vla-get-activedocument(vlax-get-acad-object))) 
  (princ)
  )

 

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


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


;;;Prüfen, ob WKS oder BKS in xy-Ausrichtung zum WKS
(defun JB_GTT:Bks-WKS:parallel-p ( / )
  (or(and(if (/=(getvar "WORLDUCS")1);;;wenn BKS
    (and(equal(caddr(trans '(1 0 0)1 0))0.0 0.0001)
        (equal(caddr(trans '(0 1 0)1 0))0.0 0.0001))
    'T)
      (equal(car (getvar "VIEWDIR"))0.0 0.0001)
      (equal(cadr (getvar "VIEWDIR"))0.0 0.0001))
  (alert (strcat "Für die Verwendung des Programms \"GTT\" müssen Sie sich im WKS oder einem BKS, dessen xy-Ebenen-Ausrichtung der xy-Ebenen-Ausrichtung des Weltkoordinatenssystems entspricht.\n"
                 "Zudem muss die DRAUFSICHT auf das aktuelle Koordinatensystem aktiviert sein."))
     )
  )
  

;;;DBox 1
(defun JB_GTT:Dbox1 (v_liste pfad_ini / DclId ok A)

  (setq Settings&Dbox1 (JB_GTT:v_liste:DboxSettings:get "Dbox1" v_liste))
  
  (while (not (member ok '(1 99)))
    (setq DclId (JBf_Dcl:Load_dialog JB_GTT_$DCL$_File "JB_GTT_1" JB_GTT$DCL$_1_po))
    (JB_GTT:Dbox1:set)
    (JB_GTT:Dbox1:mode)
    (mapcar '(lambda (A) (action_tile A (strcat "(JB_GTT:Dbox1:action \"" A "\")")))
            '("JB_1_to1" "JB_1_to2" "JB_1_to3" "JB_1_to4" "JB_1_to5" "JB_1_b1"
              "JB_1_p1" "JB_1_p2"
              "cancel"
             )
    )
    (setq ok (start_dialog))
    (unload_dialog DclId)

    (setq error&dbox1 nil)
    (if (and (= ok 1) (<=(cdr(assoc "JB_1_e1" Settings&Dbox1)) 0.0))
          (progn
            (setq ok -1)
            (setq error&dbox1 "JB_1_e1")
            (alert "Der X-Abstand muss größer Null sein."))
          )

    (if (and (= ok 1)(=(cdr(assoc "JB_1_to2" Settings&Dbox1))"1") (<=(cdr(assoc "JB_1_e2" Settings&Dbox1)) 0.0))
          (progn
            (setq ok -1)
            (setq error&dbox1 "JB_1_e2")
            (alert "Der Y-Abstand muss größer Null sein."))
          )
    
    (if (and (= ok 1) (=(cdr(assoc "JB_1_to2" Settings&Dbox1))"0")(<=(cdr(assoc "JB_1_e3" Settings&Dbox1)) 0.0))
          (progn
            (setq ok -1)
            (setq error&dbox1 "JB_1_e1")
            (alert "Die Linienlänge muss größer Null sein."))
          )
    
    (cond ((= ok 99) ;;;Ende
           (setq v_liste (JB_GTT:v_liste:DboxSettings:put "Dbox1" Settings&dbox1 v_liste))
           (JBf_SIC:sichern v_liste pfad_ini nil)
           )
          ((= ok 1) ;;;Polylinien wählen
           (setq v_liste (JB_GTT:v_liste:DboxSettings:put "Dbox1" Settings&dbox1 v_liste))
           (JBf_SIC:sichern v_liste pfad_ini nil)
           (JB_GTT:Dbox1:Gitter)
           )
          
          
          )
    ) 
  )

;;;Action (Variable global in Aufrufender Funktion)
(defun JB_GTT:Dbox1:action (key / LayerList)
  (cond
    ((= key "JB_1_to1")
     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 $value "JB_1_to1"))
     )
    ((= key "JB_1_to2")
     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 $value "JB_1_to2"))
     (JB_GTT:Dbox1:mode)
     (if (= $value "1")(mode_tile "JB_1_e2" 2))
     )
    ((= key "JB_1_to3")
     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 $value "JB_1_to3"))
     (JB_GTT:Dbox1:mode)
     (if (= $value "0")(mode_tile "JB_1_e3" 2))
     )
    ((= key "JB_1_to4")
     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 $value "JB_1_to4"))
     )

    ((= key "JB_1_to5")
     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 $value "JB_1_to5"))
     )
    
    ((= key "JB_1_b1")
     (if (setq LayerList (JB_GTT:DBox2 v_liste))
       (progn
         (setq v_liste (cadr LayerList)
               LayerList (car LayerList))
         (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 LayerList "JB_1_t1"))
         (JB_GTT:DBox1:set)
         (JB_GTT:Dbox1:mode)
         )
       )
     )
    ((= key "accept") ;;;OK, Polylinie wählen
    (JB_GTT:Dbox1:get) 
     (setq JB_GTT$DCL$_1_po (done_dialog 1))
     )
    
    ((= key "cancel") ;;;Ende
    (JB_GTT:Dbox1:get) 
     (setq JB_GTT$DCL$_1_po (done_dialog 99))
     )
    )
)


;;;DBox1: getten
(defun JB_GTT:Dbox1:get ( / )
  (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1(atof(vl-string-subst "." ","(get_tile "JB_1_e1")))"JB_1_e1"))
  (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1(atof(vl-string-subst "." ","(get_tile "JB_1_e2")))"JB_1_e2"))
  (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1(atof(vl-string-subst "." ","(get_tile "JB_1_e3")))"JB_1_e3"))
 
  )
;;;DBox1: setten
(defun JB_GTT:Dbox1:set ( / SternString X)
  (mapcar '(lambda(X)(set_tile (strcat "JB_1_"(car X))(cadr X)))
    (list
      (list "to1" (cdr(assoc "JB_1_to1" Settings&dbox1)))
      (list "to2" (cdr(assoc "JB_1_to2" Settings&dbox1)))
      (list "to3" (cdr(assoc "JB_1_to3" Settings&dbox1)))
      (list "to4" (cdr(assoc "JB_1_to4" Settings&dbox1)))
      (list "to5" (cdr(assoc "JB_1_to5" Settings&dbox1)))
      (list "t1" (cdr(assoc 2 (cdr(assoc "JB_1_t1" Settings&dbox1)))))
      (list "e1" (rtos(cdr(assoc "JB_1_e1" Settings&dbox1))2 3))
      (list "e2" (rtos(cdr(assoc "JB_1_e2" Settings&dbox1))2 3))
      (list "e3" (rtos(cdr(assoc "JB_1_e3" Settings&dbox1))2 3))
      )
    )
  )
;;;DBox1, moden
(defun JB_GTT:Dbox1:mode ( / )
  (if (/=(getvar "WORLDUCS")1)
    (mode_tile "JB_1_to1" 0)
    (mode_tile "JB_1_to1" 1)
    )
  (if (=(cdr(assoc "JB_1_to2" Settings&dbox1))"1")
    (mode_tile "JB_1_e2" 0)
    (mode_tile "JB_1_e2" 1))

  (if (=(cdr(assoc "JB_1_to3" Settings&dbox1))"1")
    (mode_tile "JB_1_e3" 1)
    (mode_tile "JB_1_e3" 0))
  
  (if error&dbox1
    (mode_tile error&dbox1 2)
    (mode_tile "JB_1_e1" 2)
    )
  )
;;;Aws mit geschlossenen Polylinien prüfen
(defun JB_GTT:Dbox1:GitterPoly:checkaws (aws / AWSRET I N)
  (setq awsRet (ssadd))
  (setq n 0)
  (setq i 0)
  (repeat (sslength aws)
    (if (JB_GTT:Dbox1:Poly:Pruef-p (ssname aws n))
      (ssadd(ssname aws n)awsRet)
      (setq i (+ i 1))
      )
    (setq n (+ n 1))
    )
  (if (/= i 0)
    (alert (strcat "Es wurde(n) " (itoa i) " Polylinie(n) aus der Auswahl entfernt weil diese nicht geschlossen war(en).")))
  (if (and awsRet
	   (/=(sslength awsRet)0))
    awsRet))
;;;Message, wenn Fehler auftritt => gibt NIL zurück
(defun JB_GTT:Dbox1:Poly:Pruef-p:Msg (msgFlag msg / )
  (if msgFLAG
    (alert msg)
  )
)
;;;Prüf-Tools für Polylinien, die ausgewählt werden: Bögen? Geschlossen?
(defun JB_GTT:Dbox1:Poly:Pruef-p (obj  / VLA-OBJ)
  ;;;Vorprüfung: wenn Kreis, dann in Poly geschlossen konvertieren
  
  (setq vla-obj (vlax-ename->vla-object obj))

    
  (and (or (member (vla-get-ObjectName vla-obj) '( "AcDb2dPolyline" "AcDbPolyline"))
           (JB_GTT:Dbox1:Poly:Pruef-p:Msg msgFlag "Die Polylinie muss eine 2D-Polylinie sein.")
       )
       (or (JB_GTT:Dbox1:Poly:Pruef-p:Closed-p vla-obj)
               (JB_GTT:Dbox1:Poly:Pruef-p:Msg msgFlag "Die Polylinie muß geschlossen sein.")
           )
  )
)
;;;;wenn Poly nicht geschlossen auf geometrische Geschlossenheit prüfen, wenn ja, dann logisch schließen
(defun JB_GTT:Dbox1:Poly:Pruef-p:Closed-p (vla-obj /)
  (or (= (vla-get-closed vla-obj) :vlax-true)
      (JB_GTT:Dbox1:Poly:Pruef-p:Closed-p:geo->logisch vla-obj)
  )
)

;;;wenn geometrisch geschlossen, dann auch logisch schließen => gleich hier auf das vla-obj anwenden
(defun JB_GTT:Dbox1:Poly:Pruef-p:Closed-p:geo->logisch (vla-obj / coords)
  (setq coords (vlax-get vla-obj 'Coordinates))
  (if
    (if (= (vla-get-ObjectName vla-obj) "AcDb2dPolyline")
      (equal (distance
               (list (car coords) (cadr coords) (caddr coords))
               (list (caddr (reverse coords)) (cadr (reverse coords)) (car (reverse coords)))
             )
             0.0 0.00001
      )
      (equal (distance
               (list (car coords) (cadr coords) 0)
               (list (cadr (reverse coords)) (car (reverse coords)) 0)
             )
             0.0 0.00001
      )
    )
    (progn
      (vla-put-closed vla-obj :vlax-true)
      (vlax-put vla-obj 'Coordinates
                (if (= (vla-get-ObjectName vla-obj) "AcDb2dPolyline")
                  (reverse(cdr(cdr(cdr(reverse coords)))))
                  (reverse(cdr(cdr(reverse coords)))))
      )
      'T
    )
  )
)

;;;Stützen der GitterLines
(defun JB_GTT:Dbox1:Gitter:stutzen (obj xyList SortFlag UcsFlag / N RETLIST SPLIST X)
  (apply 'append
         (mapcar '(lambda(X)
                    (setq RetList nil)
                    (if (and(setq spList (JBf_List:ObjSchnitt X obj))
                            (or (not UcsFlag)
                                (setq spList (mapcar '(lambda(Y)(trans Y 0 1))spList)))
                            (if (= SortFlag "SortY")
                              (setq spList(vl-sort spList '(lambda(e1 e2)(< (cadr e1)(cadr e2)))))
                              (setq spList(vl-sort spList '(lambda(e1 e2)(< (car e1)(car e2))))))
                            (or (not UcsFlag)
                                (setq spList (mapcar '(lambda(Y)(trans Y 1 0))spList)))
                            (/=(logand 1 (length spList))1))
                      (progn
                        (setq n -1)
                        ;(if (=(length spList)4)(princ "Pause"))
                        (repeat (/(length spList)2)
                          (setq n(+ n 2))
                          (entmake (list(cons 0 "LINE")(cons 10 (nth (- n 1)spList))(cons 11 (nth n spList))(cons 62 256)))                          
                          (setq RetList (cons (entlast)RetList)))
                        (entdel X)
                        RetList)
                      (list X))
                    )
           xyList)))

;;;Startwert für x und y
(defun JB_GTT:Dbox1:Gitter:StartWert (xyMin dxy / )
  (*(+(fix(/ xyMin dxy))(if (< xyMin 0.0)0 1.0))dxy)
  )

;;;Endwert für x und y
(defun JB_GTT:Dbox1:Gitter:EndWert (xyStart xyMax dxy / )
  (setq wert(/(- xyMax xyStart)dxy))
  (if (equal(- wert(fix wert))0.0 0.00001)
    (setq wert (-(fix wert)1.0))
    (setq wert (float(fix wert)))
    )
  (+ xyStart (* wert dxy))
  )

;;;WertListe für x
(defun JB_GTT:Dbox1:Gitter:WertList:X (coords dx lu ru UcsFlag / N XLIST)
  (if (equal(distance lu ru)0.0 0.00001)
    (if (and (> (car lu)(if ucsFlag(car(trans (car coords) 0 1))(car(car coords))))
             (< (car lu)(if ucsFlag(car(trans (cadr coords) 0 1))(car(cadr coords)))));;;wenn X
      (list lu)
      )
    (progn
      (setq n -1)
      (repeat (+(fix(/ (distance lu ru)dx))(+ 1 (if (=(cdr(assoc "JB_1_to5" Settings&dbox1))"1")1 0)))
        (setq n (+ n 1))
        (setq xList (cons (polar lu (angle lu ru)(* n dx))xList))
        )
      
      )
    )
  (reverse xList))

;;;WertList für y
(defun JB_GTT:Dbox1:Gitter:WertList:Y (coords dy lo lu UcsFlag / N YLIST)
  (if (equal(distance lu lo)0.0 0.00001)
    (if (and (> (cadr lu)(if ucsFlag(cadr(trans (car coords) 0 1))(cadr(car coords))))
             (< (cadr lu)(if ucsFlag(cadr(trans (caddr coords) 0 1))(cadr(caddr coords)))));;;wenn Y
      (list lu)
      )
    (progn
      (setq n -1)
      (repeat (+(fix(/ (distance lu lo)dy))(+ 1 (if (=(cdr(assoc "JB_1_to5" Settings&dbox1))"1")1 0)))
        (setq n (+ n 1))
        (setq yList (cons (polar lu (angle lu lo)(* n dy))yList))
        )
      )
    )
  (reverse yList))


;;;Blockname für Legende, wenn bereits Blocknamen vorhanden, dann bereinigen, wenn keine Referenz vorhanden
(defun JB_GTT:DBox1:Gitter:Kreuze:Insert:AsBlock:BlockName ( / N NAMELIST)
  (vlax-for ITEM (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object)))
    (if (= (vl-string-search "GTT_" (vla-get-Name ITEM))0)
      (if (not (ssget "_X" (list (cons 0 "INSERT")(cons 2 (vla-get-Name ITEM)))))
        (vla-delete ITEM)
        (setq NameList (cons (vla-get-name ITEM)NameList))
        )
      )
    )

  (if NameList
    (setq n (+(atoi(vl-string-left-trim "GTT_"(car(vl-sort NameList '(lambda(e1 e2)(> e1 e2))))))1))
    (setq n 1)
    )

  (strcat "GTT_" (itoa n))
  )

;;;Kopieren von Objekten aus Modelbereich in Blockdefinition
;;;Rückgabe 'T, wenn erfolgreich oder gar kein array, wenn NIL, dann fehler bei array-Bildung => irgendeins von den Objekten war wohl schlecht.
(defun JB_GTT:DBox1:Gitter:Kreuze:Insert:AsBlock:CopyObjFromModel (vla-doc vla-BlockDef vla-CopyList /)

  (if vla-CopyList
    (setq RetList
	   (vlax-safearray->list
	     (vlax-variant-value
	       (vla-CopyObjects
		 vla-doc
		 (vlax-safearray-fill
		   (vlax-make-safearray
		     vlax-vbObject
		     (cons 0 (- (length vla-CopyList) 1))
		     )
		   (reverse vla-CopyList)
		   )
		 vla-BlockDef
		 )
	       )
	     )
	  )
    )

  (mapcar 'vla-delete vla-CopyList)
  RetList
)
  
;;;Legende als Block einfügen
(defun JB_GTT:DBox1:Gitter:Kreuze:Insert:AsBlock (vla-objList spList wx / NAME PUR VLA-BLOCKDEF VLA-DOC VLA-OBJ VLA-OBJLIST4SCALE X)
  (setq spList (mapcar '(lambda(X)(trans X 0 1))spList))
  (setq pUr (trans(car(vl-sort spList '(lambda(e1 e2)(and (< (car e1)(car e2))(< (cadr e1)(cadr e2))))))1 0))
  (if(/=(getvar "WORLDUCS")1);;;wenn BKS
    (mapcar '(lambda(vla-obj)
               (vla-TransformBy vla-obj (vlax-tmatrix (JBf_PointInPoly:TransMatrix:VonNach 1 0)))
               )
      vla-objList))
  (mapcar '(lambda(vla-obj)
             (vla-move vla-obj (vlax-3D-point (trans pUr 0 1))(vlax-3D-point '(0 0 0))))
    vla-objList)
  (setq Name (JB_GTT:DBox1:Gitter:Kreuze:Insert:AsBlock:BlockName))
  (setq vla-BlockDef (vla-add (vla-get-Blocks (setq vla-doc (vla-get-ActiveDocument (vlax-get-acad-object))))
					  (vlax-3d-point '(0 0 0))
					  Name))
					 
  (JB_GTT:DBox1:Gitter:Kreuze:Insert:AsBlock:CopyObjFromModel vla-doc vla-BlockDef vla-objList)
  (JBf_VlaAdd:AddBlock Name (vlax-3d-point pUr) 1.0 (cdr(assoc 2(cdr(assoc "JB_1_t1" Settings&dbox1)))) (- wx (* 0.5 pi)) (vlax-3d-point '(0 0 1))
    nil
    'T;;;FeldBlockerFlag
    )
  )
;;;Kreuze zeichen
(defun JB_GTT:DBox1:Gitter:Kreuze (xList yList /  SP SPLIST VLA-OBJLIST VLA-RETLIST WX X)
  
    (setq wx (angle (vlax-get(vlax-ename->vla-object(car xList))'StartPoint)(vlax-get(vlax-ename->vla-object(car xList))'EndPoint)))
    (mapcar '(lambda(X)
                 (mapcar '(lambda(Y)
                            (mapcar '(lambda(sp)
                                       (setq spList (cons sp spList))
                                       (entmake (list(cons 0 "LINE")
                                                     (cons 8 (cdr(assoc 2 (cdr(assoc "JB_1_t1" Settings&dbox1)))))
                                                     (cons 10 (polar sp (+ wx pi)(/(cdr(assoc "JB_1_e3" Settings&dbox1))2.0)))
                                                     (cons 11 (polar sp wx(/(cdr(assoc "JB_1_e3" Settings&dbox1))2.0)))
                                                     (cons 62 256)))
                                       (setq vla-objList (cons (vlax-ename->vla-object(entlast))vla-objList))
                                       (entmake (list(cons 0 "LINE")
                                                     (cons 8 (cdr(assoc 2 (cdr(assoc "JB_1_t1" Settings&dbox1)))))
                                                     (cons 10 (polar sp (+ wx (* pi 1.5))(/(cdr(assoc "JB_1_e3" Settings&dbox1))2.0)))
                                                     (cons 11 (polar sp (+ wx (* pi 0.5))(/(cdr(assoc "JB_1_e3" Settings&dbox1))2.0)))
                                                     (cons 62 256)))
                                       (setq vla-objList (cons (vlax-ename->vla-object(entlast))vla-objList))
                                       )
                              (JBf_List:ObjSchnitt X Y)
                              )
                            )
                   yList)
                 )
        xList)
    (if (=(cdr(assoc "JB_1_to4" Settings&dbox1))"1")
      (JB_GTT:DBox1:Gitter:Kreuze:Insert:AsBlock vla-objList spList wx)
      )
  (mapcar 'vla-delete(mapcar 'vlax-ename->vla-object (append xList yList)))
  )
;;;Ganze Linien
(defun JB_GTT:DBox1:Gitter:All (xList yList / COORDS VLA-OBJLIST WX X)
  (if (=(cdr(assoc "JB_1_to4" Settings&dbox1))"1")
      (progn
        (setq wx (angle (vlax-get(vlax-ename->vla-object(car xList))'StartPoint)(vlax-get(vlax-ename->vla-object(car xList))'EndPoint)))
        (setq vla-objList(mapcar 'vlax-ename->vla-object(append xList yList)))
        (setq coords (apply 'append
                            (mapcar '(lambda(X)
                                       (list(vlax-get X 'StartPoint)
                                            (vlax-get X 'EndPoint)))vla-objList)))
        (JB_GTT:DBox1:Gitter:Kreuze:Insert:AsBlock vla-objList coords wx)
        )
      (mapcar '(lambda(X)
                 (vla-put-color X 256)
                 (vla-put-layer X (cdr(assoc 2 (cdr(assoc "JB_1_t1" Settings&dbox1))))))
        (mapcar 'vlax-ename->vla-object(append xList yList)))
      )
  )

;;;DBox1, Gitter einfügen
(defun JB_GTT:Dbox1:Gitter ( / AWS AWS_ERROR COORDS DX DY L LO LU N OBJ RO RU SPLIST UCSFLAG VLA-OBJ W WCSAKTIV X XEND XLIST XSTART YEND YLIST YSTART Z)
  (if (and (princ "\nWählen Sie geschlossene Polylinien:")
           (setq aws (ssget (list (cons 0 "POLYLINE,LWPOLYLINE"))))
           (setq aws (JB_GTT:Dbox1:GitterPoly:checkaws aws)))
    (progn
      (setq aws_error(ssadd))
      (if (not (tblsearch "LAYER" (cdr(assoc 2 (cdr(assoc "JB_1_t1" Settings&dbox1))))))
        (entmake (cdr(assoc "JB_1_t1" Settings&dbox1))))
      (setq n 0)
      (repeat (sslength aws)
        (setq obj (ssname aws n))
        (setq vla-obj (vlax-ename->vla-object obj))        
        (setq ucsFlag (and (not (=(getvar "WORLDUCS")1)) (=(cdr(assoc "JB_1_to1" Settings&dbox1))"1")))
        (setq dx (cdr(assoc "JB_1_e1" Settings&dbox1)))
        (setq dy (if (=(cdr(assoc "JB_1_to2" Settings&dbox1))"1")
                   (cdr(assoc "JB_1_e2" Settings&dbox1))
                   (cdr(assoc "JB_1_e1" Settings&dbox1))))
        (setq l (vla-get-length vla-obj))
        (setq coords(mapcar '(lambda(X)(if ucsFlag(trans X 0 1)X))(JBf_PointInPoly:BoundingBox vla-obj (=(getvar "WORLDUCS")1) (=(cdr(assoc "JB_1_to1" Settings&dbox1))"1"))))
        (setq xStart (JB_GTT:Dbox1:Gitter:StartWert (car(car coords))dx))
        (setq yStart (JB_GTT:Dbox1:Gitter:StartWert (cadr(car coords))dy))
        (setq xEnd (JB_GTT:Dbox1:Gitter:EndWert xStart (car(caddr coords)) dx))
        (setq yEnd (JB_GTT:Dbox1:Gitter:EndWert yStart (cadr(caddr coords)) dx))
        (setq z (vla-get-Elevation vla-obj))
        (setq lu(if ucsFlag(trans(list xStart yStart z)1 0)(list xStart yStart z)))
        (setq ro(if ucsFlag(trans(list xEnd yEnd z)1 0)(list xEnd yEnd z)))
        (setq w (if ucsFlag (angle (trans'(0 0 0)1 0) (trans '(1 0 0)1 0))(angle '(0 0 0) '(1 0 0))))
        (setq ru(polar lu w (- (if ucsFlag(car(trans ro 0 1))(car ro))(if ucsFlag(car(trans lu 0 1))(car lu)))))
        (setq lo(polar ro w (- (if ucsFlag(car(trans lu 0 1))(car lu))(if ucsFlag(car(trans ro 0 1))(car ro)))))

        ;;;X-Listen erstellen
        (setq xList(vl-remove-if 'not
                     (mapcar '(lambda(X)
                              (entmake (list (cons 0 "LINE")(cons 10 (polar X (- w (* 0.5 pi))(if (> l dx)l dx)))(cons 11 (polar X (+ w (* 0.5 pi))(if (> l dx)l dx)))(cons 62 256)))
                              (if (and(setq spList(JBf_List:ObjSchnitt (entlast) (ssname aws n)))
                                      (/=(logand 1 (length spList))1))
                                (entlast)
                                (vla-delete (vlax-ename->vla-object(entlast)))
                                )
                              )
                     (JB_GTT:Dbox1:Gitter:WertList:X coords dx lu ru UcsFlag)
                     ))
              )
        
        ;;;Y-Liste erstellen
        (setq yList(vl-remove-if 'not
                     (mapcar '(lambda(X)
                              (entmake (list (cons 0 "LINE")(cons 10 (polar X (+ w pi)(if (> l dy)l dy)))(cons 11 (polar X w (if (> l dy)l dy)))(cons 62 256)))
                              (if (and(setq spList(JBf_List:ObjSchnitt (entlast) (ssname aws n)))
                                      (/=(logand 1 (length spList))1))
                                (entlast)
                                (vla-delete (vlax-ename->vla-object(entlast)))
                                )
                              )
                     (JB_GTT:Dbox1:Gitter:WertList:Y coords dy lo lu UcsFlag)
                     ))
              )
        (if (and xList yList)
          (progn
            (setq xList(JB_GTT:Dbox1:Gitter:stutzen obj xList "SortY" (and (not WcsAktiv) ucsFlag)))
            (setq yList(JB_GTT:Dbox1:Gitter:stutzen obj yList "SortX" (and (not WcsAktiv) ucsFlag)))
            (if (=(cdr(assoc "JB_1_to3" Settings&dbox1))"0")
              (JB_GTT:DBox1:Gitter:Kreuze xList yList)
              (JB_GTT:DBox1:Gitter:All xList yList)
              )
            )
          (progn
            (ssadd(ssname aws n)aws_error)
            (mapcar 'vla-delete(mapcar 'vlax-ename->vla-object (append xList yList)))
            )
          )
            
        (setq n (+ n 1))
        )
      (if (and aws_error (/=(sslength aws_error)0))
        (progn
          (sssetfirst aws_error aws_error)
          (alert (strcat "Es wurde(n) " (itoa(sslength aws_error)) " Polylinie(n) selektiert, bei denen keine Gitter erzeugt worden sind (zu klein, falsche Position).")))
        )
      )
    )

  )
      
;;;DBox2, setten
(defun JB_GTT:Dbox2:set ( / X)
  (JBf_Dcl:AddList:New "JB_2_l1" l1&Dbox2)
  (if l1_sel&Dbox2
    (set_tile "JB_2_l1" (itoa l1_sel&Dbox2)))
  (set_tile "JB_2_t1" (cdr(assoc "JB_2_t1" Settings&dbox2)))
)
;;;DBox2, moden
(defun JB_GTT:Dbox2:mode ( / )
  (if l1&Dbox2
    (progn
      (mode_tile "JB_2_l1" 0)
      (mode_tile "accept" 0)
      (mode_tile "JB_2_l1" 2)
      )
    (progn
      (mode_tile "JB_2_l1" 1)
      (mode_tile "accept" 1)
      (alert "Es entspricht kein Layer dem aktuellen Filter.")
      )
    )
  )

(defun JB_GTT:Dbox2:Ini ( / )
  (if (not LayerList&Dbox2)
    (vlax-for ITEM
           (vla-get-Layers(vla-get-activeDocument (vlax-get-acad-object)))
      (setq LayerList&Dbox2 (cons (vla-get-name ITEM)LayerList&Dbox2)))
    )
  
  (setq l1&DBox2 (vl-sort (vl-remove-if '(lambda(X)
                                           (not(wcmatch (strcase X)
                                                 (strcase(cdr(assoc "JB_2_t1" Settings&dbox2)))))
                                           )LayerList&Dbox2)
                   '(lambda(e1 e2)(< e1 e2))))
  (if l1&DBox2 (setq l1_sel&Dbox2 0))
  )
;;;DBox2 => Layer
(defun JB_GTT:Dbox2 (v_liste / l1&Dbox2 l1_sel&Dbox2 LayerList&Dbox2 DclId Settings&dbox2 ok LAYERLIST)

  (setq Settings&Dbox2 (JB_GTT:v_liste:DboxSettings:get "Dbox2" v_liste))

  (JB_GTT:Dbox2:Ini)

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

    (setq DclId (JBf_Dcl:Load_dialog JB_GTT_$DCL$_File "JB_GTT_2" JB_GTT$DCL$_2_po))

    (JB_GTT:Dbox2:set)
    (JB_GTT:Dbox2:mode)
    
    (mapcar (function (lambda (A) (action_tile A (strcat "(JB_GTT:Dbox2:action \"" A "\")"))))
            '(
               "JB_2_l1"
               "JB_2_b1"
               "accept" "cancel"
             )
    )
    (setq ok (start_dialog))
    (unload_dialog DclId)
    (if (= ok 1)
      (progn
        (setq LayerList (vl-remove-if '(lambda(X)(not(member(car X)'(0 100 2 70 62 6 290 370))))(entget(tblobjname "LAYER"(nth l1_sel&Dbox2 l1&Dbox2)))))
        (setq v_liste (JB_GTT:v_liste:DboxSettings:put "Dbox2" Settings&dbox2 v_liste))
        )
      )
    )
  (if (= ok 1)
    (list LayerList v_liste))
  )
;;;Action (Variable global in Aufrufender Funktion)
(defun JB_GTT:Dbox2:action (key / Filter)

  (cond
    ((= key "JB_2_l1")
     (setq l1_sel&Dbox2 (atoi $value))
     )
    ((= key "JB_2_b1")
     (if (setq filter (JB_GTT:DBox3 (cdr(assoc "JB_2_t1" Settings&dbox2))))
       (progn
         (setq Settings&dbox2 (JBf_list:subst:gc Settings&dbox2 filter "JB_2_t1"))
         (JB_GTT:Dbox2:Ini)
         (JB_GTT:Dbox2:set)
         (JB_GTT:Dbox2:mode)
         )
       )
     )
    ((= key "accept");;;ok
     (setq JB_GTT$DCL$_2_po (done_dialog 1))
    )
    ((= key "cancel")    ;;;Abbrechen
     (setq JB_GTT$DCL$_2_po (done_dialog 99))
    )

  )
)
;;;DBox3 => Filtername
(defun JB_GTT:Dbox3 (Filter&Dboix3 / DclId ok)
  (while (not(member ok '(1 99)))
    (setq DclId (JBf_Dcl:Load_dialog JB_GTT_$DCL$_File "JB_GTT_3" JB_GTT$DCL$_3_po))

    (set_tile "JB_3_e1" Filter&Dboix3)
    (mode_tile "JB_3_e1" 2)
    (mapcar (function (lambda (A) (action_tile A (strcat "(JB_GTT:Dbox3:action \"" A "\")"))))
            '(
               "accept" "cancel"
             )
    )
    (setq ok (start_dialog))
    (unload_dialog DclId)    
    )

  (if (= ok 1)
    Filter&Dboix3)
  )
;;;Action (Variable global in Aufrufender Funktion)
(defun JB_GTT:Dbox3:action (key / Filter)

  (cond
    ((= key "accept");;;ok
     (setq Filter&Dboix3 (get_tile "JB_3_e1"))
     (setq JB_GTT$DCL$_2_po (done_dialog 1))
    )
    ((= key "cancel")    ;;;Abbrechen
     (setq JB_GTT$DCL$_2_po (done_dialog 99))
    )

  )
)
         
;;;DCL-schreiben
(defun JB_GTT:dcl:Write ( / file)  
  (if (and (setq JB_GTT_$DCL$_File (vl-filename-mktemp (strcat "GTT.dcl")))
           (setq file (open JB_GTT_$DCL$_File "w"))
      )
    (progn
      (mapcar '(lambda (A)
                       (write-line A file)
               )
              (mapcar '(lambda (A)
                               (strcat "\n" A)
                       )
              (list
                "//Hauptdialog"
                "JB_GTT_1: dialog {label= \"Gitterkreuze in Polylinie\";	 "
                ":boxed_column {label = \"Kreuze, Gitterlinien\";"
                ":toggle {key = \"JB_1_to1\"; label = \"BKS verwenden\";}"
                ":edit_box {key = \"JB_1_e1\"; label = \"Gitter-Abstand X\";edit_width = 8;}"
                ":row {"
                ":toggle {key = \"JB_1_to2\"; label = \"Gitter-Abstand in Y separat\";}"
                ":edit_box {key = \"JB_1_e2\";edit_width = 8;}}"
                ":edit_box {key = \"JB_1_e3\"; label = \"Gitterlinienlänge\";edit_width = 8;}"
                ":toggle {key = \"JB_1_to3\"; label = \"Gitterlinien bis an die Polylinie\";}"
                ":toggle {key = \"JB_1_to4\"; label = \"Gitter als Block\";}"
                ":toggle {key = \"JB_1_to5\"; label = \"Gitteranzahl +1, falls Lücken in Randbereichen entstehen\";}"
                ":row{"
                ":button {key = \"JB_1_b1\"; label = \"&Layer...\"; fixed_width = true;}"
                ":text {key = \"JB_1_t1\"; label = \"*\";width= 50;}"
                "}}"
                ":row{fixed_width = true;alignment = centered;"
                ":button {key = \"accept\"; label = \"Polylinien wählen<\";width=20; is_default=true;}"
                ":spacer {width = 2;}"
                ":retirement_button {label = \"&Ende\"; key= \"cancel\"; fixed_width = true;is_cancel=true;}"
                "}"
                "}"
                "JB_GTT_2: dialog {label= \"Layer\";"
                ":boxed_column {label = \"Layerliste\";"
                ":list_box {key = \"JB_2_l1\"; label = \"Layer\"; width = 60; height = 20; allow_accept = true;}"
                ":row{"
                ":button {key = \"JB_2_b1\"; label = \"&Filter...\"; fixed_width = true;}"
                ":text {key = \"JB_2_t1\"; label = \"*\";width= 50;}"
                "}"
                "}"
                "ok_cancel;}"
                "JB_GTT_3: dialog {label = \"Filter\";"
                ":boxed_column {label = \"Bitte eingeben\";"
                ":edit_box {key = \"JB_3_e1\"; edit_width = 30; allow_accept = true;}}"
                "ok_cancel;}"

               )
              )
      )
      (close file)
      JB_GTT_$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))


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

;;Prüfen, ob in AttDef ein Schriftfeld vorhanden ist
(defun JBf_VlaAdd:AddBlock:FieldInAtt? (vla-Att / RETVAL)
  (vlax-for ITEM
	    (vla-GetExtensionDictionary
                       vla-Att)
    (if (=(vla-get-name ITEM)"ACAD_FIELD")
      (setq RetVal 'T)))
  RetVal)
;;;Schnittpunkte zweier Linienobjekte
(defun JBf_List:ObjSchnitt (obj1 obj2 / SpArray)

  (setq SpArray (vlax-invoke-method (vlax-ename->vla-object obj1)
                                    'IntersectWith
                                    (vlax-ename->vla-object obj2) acExtendNone
                )
  )

  (if (/= -1 (vlax-safearray-get-u-bound (vlax-variant-value SpArray) 1))
    (JBf_List:ObjSchnitt:ArrayList->List (vlax-safearray->list (vlax-variant-value SpArray)) 3)
  )
)
;;;ArrayList in normale Liste
(defun JBf_List:ObjSchnitt:ArrayList->List (ArrayList i / A N RETLIST SUBLIST)
  (setq n 0)
  (mapcar '(lambda (A)
                   (setq n (+ n 1)
                         subList (cons A subList)
                   )
                   (if (= n i)
                     (setq retList (cons (reverse subList) retList)
                           n 0
                           subList nil
                     )
                   )
           )
          ArrayList
  )
  retList
  )
;;;--------------------------------------------------------------------------------------------------------
;;;allgemeine VLa-Funktionen 							       			   
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

;;;FeldBlockFlag: wenn 'T, dann wird bei der Vergabe von Textwerten geprüft, ob im Attribut ein Feld definiert ist, wenn ja, dann wird der Textwert nicht übertragen => das Schriftfeld bleibt erhalten
(defun JBf_VlaAdd:AddBlock (BlockName 3d-InsPoint ScaleFactor Layer Rotation 3d-Normal AttListFill FeldBlockerFlag / ATTLIST SPACE VLA-ATT VLA-OBJ X Y)
  
 (if (or(= (strcase (getvar "CTAB")) "MODEL")
         (/=(getvar "CVPORT")1))
    (setq Space (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
    (setq Space (vla-get-PaperSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
    )

  (setq	vla-obj
         (vla-insertblock
           Space
           (vlax-3d-point '(0 0 0))
           BlockName
	   ScaleFactor
	   ScaleFactor
	   ScaleFactor
	   Rotation
	 ))

  (vla-put-Layer vla-obj Layer)
  (vla-put-Normal vla-obj 3d-Normal)
  ;;;(vla-put-InsertionPoint vla-obj 3d-InsPoint) => musste deaktiviert und durch vla-move ersetzt werden, weil sonst Attribute mit Ausrichtung Mitte-Links die doppelte Höhe erhalten 07.09.18
  (vla-Move vla-obj (vlax-3d-point '(0 0 0)) 3d-InsPoint)
  
  (if (and AttListFill(=(vla-get-HasAttributes vla-obj):vlax-true)
	   (setq AttList (mapcar '(lambda (X)(cons (strcase(vla-get-TagString X))X))
			    (vlax-invoke vla-obj 'getAttributes))))
    (mapcar '(lambda(X)
	       (if (setq vla-att(cdr(assoc (car X)AttList)))		       
		 (mapcar '(lambda(Y)
			    (if(or (not FeldBlockerFlag)
				   (/= (car Y)'TEXTSTRING)
				   (and (=(car Y)'TEXTSTRING)
					(not (JBf_VlaAdd:AddBlock:FieldInAtt? vla-att))))
			      (if (vlax-property-available-p vla-att(car Y))
				(vlax-put vla-att (car Y)(cadr Y))))
			    )
			 (cadr X))))

	    AttListFill))
  
  vla-obj)
;;;Transformationsmatrix 4x4
(defun JBf_PointInPoly:TransMatrix:VonNach (von nach / X Y)
  (append
    (mapcar
      '(lambda(X Y)
         (append (trans X von nach 'T) (list Y))
         )
      (list '(1.0 0.0 0.0) '(0.0 1.0 0.0) '(0.0 0.0 1.0))
      (trans '(0.0 0.0 0.0) nach von)
      )
    (list '(0.0 0.0 0.0 1.0))
    )
  )

;;;Bonding-Box, Welt oder BKS
;;;Argumente: vla-obj => wenn Boundingbox verfügbar, dann Rückgabe der Liste ((p1 p2 p3 p4)vla-obj)
;;;WcsAktiv: 'T or NIL
;;;ucsFlag:  'T or NIL => wenn 'T und WcsAktiv NIL, dann wird vor der Bounding-Funktion das vla-obj in das BKS transformiert, gilt nur, wenn die Hochzugsrichtung des BKS's dem WKS entspricht

(defun JBf_PointInPoly:BoundingBox (vla-obj WcsAktiv ucsFlag / COORDS MAXXYZ MINXYZ X)
  (if (vlax-method-applicable-p vla-obj 'getboundingbox)
    (progn
      (if (and (not WcsAktiv)ucsFlag)
        (vla-TransformBy vla-obj (vlax-tmatrix (JBf_PointInPoly:TransMatrix:VonNach 1 0)))
        )
      (vla-getboundingbox vla-obj 'minXYZ 'maxXYZ)
      (setq minXYZ(vlax-safeArray->list minXYZ))
      (setq maxXYZ(vlax-safeArray->list maxXYZ))
      (setq coords (list (list (car minXYZ)(cadr minXYZ)0.0)
                         (list (car maxXYZ)(cadr minXYZ)0.0)
                         (list (car maxXYZ)(cadr maxXYZ)0.0)
                         (list (car minXYZ)(cadr maxXYZ)0.0)))
      (if (and (not WcsAktiv)ucsFlag)
        (progn
          (vla-TransformBy vla-obj (vlax-tmatrix (JBf_PointInPoly:TransMatrix:VonNach 0 1)))
          (setq coords(mapcar '(lambda(X)
                                 (trans X 1 0))coords))
          )
        )
      )
    )
  coords)
;;;Prüfen, ob in AttDef ein Schriftfeld vorhanden ist
(defun JBf_VlaAdd:AddBlock:FieldInAtt? (vla-Att / RETVAL)
  (vlax-for ITEM
	    (vla-GetExtensionDictionary
                       vla-Att)
    (if (=(vla-get-name ITEM)"ACAD_FIELD")
      (setq RetVal 'T)))
  RetVal)
;;;FeldBlockFlag: wenn 'T, dann wird bei der Vergabe von Textwerten geprüft, ob im Attribut ein Feld definiert ist, wenn ja, dann wird der Textwert nicht übertragen => das Schriftfeld bleibt erhalten
(defun JBf_VlaAdd:AddBlock (BlockName 3d-InsPoint ScaleFactor Layer Rotation 3d-Normal AttListFill FeldBlockerFlag / ATTLIST SPACE VLA-ATT VLA-OBJ X Y)
  
 (if (or(= (strcase (getvar "CTAB")) "MODEL")
         (/=(getvar "CVPORT")1))
    (setq Space (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
    (setq Space (vla-get-PaperSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
    )

  (setq	vla-obj
         (vla-insertblock
           Space
           (vlax-3d-point '(0 0 0))
           BlockName
	   ScaleFactor
	   ScaleFactor
	   ScaleFactor
	   Rotation
	 ))

  (vla-put-Layer vla-obj Layer)
  (vla-put-Normal vla-obj 3d-Normal)
  ;;;(vla-put-InsertionPoint vla-obj 3d-InsPoint) => musste deaktiviert und durch vla-move ersetzt werden, weil sonst Attribute mit Ausrichtung Mitte-Links die doppelte Höhe erhalten 07.09.18
  (vla-Move vla-obj (vlax-3d-point '(0 0 0)) 3d-InsPoint)  
  (if (and AttListFill(=(vla-get-HasAttributes vla-obj):vlax-true)
	   (setq AttList (mapcar '(lambda (X)(cons (strcase(vla-get-TagString X))X))
			    (vlax-invoke vla-obj 'getAttributes))))
    (mapcar '(lambda(X)
	       (if (setq vla-att(cdr(assoc (car X)AttList)))		       
		 (mapcar '(lambda(Y)
			    (if(or (not FeldBlockerFlag)
				   (/= (car Y)'TEXTSTRING)
				   (and (=(car Y)'TEXTSTRING)
					(not (JBf_VlaAdd:AddBlock:FieldInAtt? vla-att))))
			      (if (vlax-property-available-p vla-att(car Y))
				(vlax-put vla-att (car Y)(cadr Y))))
			    )
			 (cadr X))))

	    AttListFill))
  
  vla-obj) 

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

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

(princ (strcat
          "\n|++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++|"
          "\n|Gitterkreuze in Polylinie einfügen.                         |"
          "\n|------------------------------------------------------------|"
          "\n|erstellt durch Bosse-engineering - www.bosse-engineering.com|"
          "\n|------------------------------------------------------------|"
          "\n|Befehlszeilenaufruf: GTT                                    |"
          "\n|++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++|"
          )
       )
(princ)










