
;;;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: 3DPB - Es werden 3D-Punktblöcke auf neue 3D-Polylinien-Stützpunkte gesetzt. Die xy-Position 
;;;wird durch Picken oder durch eine Schnittlinie bestimmt. Wenn ein Punktblock entfernt wird, dann werden 
;;;auch positions-identische Stützpunkte von 3D-Polylinien entfernt.					   
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;;;globale Variablen:										   	   
;;;- JB_3DPB$DCL$_[x]_po (Positionen der Dialogfenster)							   
;;;- JB_3DPB_$DCL$_File (temporäre DCL-Datei)								   
;;;                                                                              Jörn Bosse, 14.06.23	   
;;;--------------------------------------------------------------------------------------------------------



;;;aufrufenden Funktionen
(defun c:3DPB ( / )
  (JB_3DPB)
  )

;;;Intro
(defun JB_3DPB:Intro (str / )
  (princ "\nerstellt durch Bosse-engineering - www.bosse-engineering.com\n")
  (princ "\n----------------------3DPB(1.0), 14.06.23---------------------")
  (princ str)
  (princ "\n--------------------------------------------------------------")
  )




;;;Variablenliste
(defun JB_3DPB:v_liste ( / )
  '(
     ( "DboxSettings" . (
                         ( "Dbox1" .
                            (
                             ("JB_1_b1" . "");;;Blockname
                             ("JB_1_p1" . "");;;Attributname Nummer
                             ("JB_1_p2" . "");;;Attributname Hoehe
                             ("JB_1_e1" . "1.0");;;Faktor
                             ("JB_1_e2" . "3DPB");;;Einfügelayer
                             ("JB_1_e3" . "2");;;Nachkommastellen Attribut
                             ("JB_1_e4" . "1000");;;Last Punktnummer
                              
                             ( "LastButton" . "JB_1_b1")
                             )
                          )
                         )
      ))
  )


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

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

  (setq pfad_ini (JB_3DPB: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_3DPB:v_liste))pfad_ini nil))
  
  (vla-startundomark (vla-get-activedocument(vlax-get-acad-object)))
  (JBf_init
    '(("CMDECHO" 0)
      ("DIMZIN" 3)
      ))
  
  
  (JB_3DPB:Intro "\n3DPB: 3D-Polylinien - Punktblöcke.")

  
  

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


  (if (JB_3DPB:Bks-WKS:parallel-p)
    (JB_3DPB: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_3DPB:v_liste:DboxSettings:get (key v_liste / )
  (cdr(assoc key(cdr (assoc "DboxSettings" v_liste))))
)


(defun JB_3DPB: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_3DPB: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 \"3DPB\" 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."))
     )
  )
  

        
    

;;;Punktnummerliste
(defun JB_3DPB:Dbox1:PNRList ( / AWS N VLA-ATT)
  (if(setq aws (ssget "_X" (list (cons 0 "INSERT")(cons 2 (cdr(assoc "JB_1_b1" Settings&Dbox1)))(cons 410 "Model"))))
    (progn
      (setq n 0)
      (repeat (sslength aws)
        (if (setq vla-att (cadr(assoc (strcase(cdr(assoc "JB_1_p1" Settings&Dbox1)))
                                      (JBf_list_att_aus_block_vla-obj(vlax-ename->vla-object(ssname aws n))))))
          (setq Pnr&DBox1 (cons (vla-get-Textstring vla-att)Pnr&DBox1))
          )
        (setq n (+ n 1)))
      )
    )
  )

;;;Attribut Ini
(defun JB_3DPB:Dbox1:att:ini ( /  VLA-ATTLIST X)
  (if (and(tblsearch "BLOCK" (cdr(assoc "JB_1_b1" Settings&Dbox1)))
          (setq vla-attList (mapcar '(lambda(X)
                                       (list (vla-get-Tagstring X)X))
                              (JBf_list_att_aus_vla-blockdef (cdr(assoc "JB_1_b1" Settings&Dbox1))))))
    (setq p1&Dbox1 (mapcar 'car vla-attList)
          p2&Dbox1 (mapcar 'car vla-attList)
          p1_sel&Dbox1 (if (member(strcase(cdr(assoc "JB_1_p1" Settings&Dbox1)))(mapcar 'strcase (mapcar 'car vla-attList)))
                   (-(length vla-attList)(length(member(strcase(cdr(assoc "JB_1_p1" Settings&Dbox1)))(mapcar 'strcase (mapcar 'car vla-attList)))))
                   0)
          p2_sel&Dbox1 (if (member(strcase(cdr(assoc "JB_1_p2" Settings&Dbox1)))(mapcar 'strcase (mapcar 'car vla-attList)))
                   (-(length vla-attList)(length(member(strcase(cdr(assoc "JB_1_p2" Settings&Dbox1)))(mapcar 'strcase (mapcar 'car vla-attList)))))
                   0)
          )
    )
  )




;;;DBox 1
(defun JB_3DPB:Dbox1 (v_liste pfad_ini / Pnr&Dbox1 p1&Dbox1 p1_sel&Dbox1 p2&Dbox1 p2_sel&Dbox1 DCLID OK SETTINGS&DBOX1 A error&dbox1)

  (setq Settings&Dbox1 (JB_3DPB:v_liste:DboxSettings:get "Dbox1" v_liste))
  (JB_3DPB:Dbox1:PNRList)
  (JB_3DPB:Dbox1:att:ini)
  
  
      
  (while (not (member ok '(99)))

    (setq DclId (JBf_Dcl:Load_dialog JB_3DPB_$DCL$_File "JB_3DPB_1" JB_3DPB$DCL$_1_po))

    (JB_3DPB:Dbox1:set)
    (JB_3DPB:Dbox1:mode)
    
    
    (mapcar '(lambda (A) (action_tile A (strcat "(JB_3DPB:Dbox1:action \"" A "\")")))
            '("JB_1_b1" "JB_1_b2" "JB_1_b3" "JB_1_b4" "JB_1_b5" "JB_1_b0"              
              "JB_1_p1" "JB_1_p2"
              "cancel"
             )
    )
    (setq ok (start_dialog))
    (unload_dialog DclId)

    (setq error&dbox1 nil)

    (if (member ok '(12 13))
      (progn
        (if (and (member ok '(12 13)) (<=(atof(cdr(assoc "JB_1_e1" Settings&Dbox1)))0.0))
          (progn
            (setq ok -1)
            (setq error&dbox1 "JB_1_e1")
            (alert "Der Faktor muss größer Null sein."))
          )
        (if (and (member ok '(12 13)) (=(cdr(assoc "JB_1_p1" Settings&Dbox1))(cdr(assoc "JB_1_p2" Settings&Dbox1))))
          (progn
            (setq ok -1)
            (setq error&dbox1 "JB_1_p1")
            (alert "Die Attributnamen für Nummer und Hoehe müssen verschieden sein."))
          )
        (if (and (member ok '(12 13)) (not(snvalid(cdr(assoc "JB_1_e2" Settings&Dbox1)))))
          (progn
            (setq ok -1)
            (setq error&dbox1 "JB_1_e2")
            (alert "Der Layername enthält ungültige Zeichnen."))
          )
        )
      )
      
    
    (cond ((= ok 99) ;;;Ende
           (setq v_liste (JB_3DPB:v_liste:DboxSettings:put "Dbox1" Settings&dbox1 v_liste))
           (JBf_SIC:sichern v_liste pfad_ini nil)
           )
          ((= ok 11);;;Objekte aus Zeichnung für Layerliste
           (if(setq BlockName(JB_3DPB:Dbox1:action:BlockAusCad))
             (JB_3DPB:Dbox1:action:b0-b1)
             )
           )
          ((= ok 12)
           (JB_3DPB:Dbox1:exe:Einzel)
           (setq v_liste (JB_3DPB:v_liste:DboxSettings:put "Dbox1" Settings&dbox1 v_liste))
           (JBf_SIC:sichern v_liste pfad_ini nil)
           )
          ((= ok 13)
           (JB_3DPB:Dbox1:exe:Schnittlinie)
           (setq v_liste (JB_3DPB:v_liste:DboxSettings:put "Dbox1" Settings&dbox1 v_liste))
           (JBf_SIC:sichern v_liste pfad_ini nil)
           )
          ((= ok 14)
           (JB_3DPB:Dbox1:exe:Bloecke:entf)
           )
          ((= ok 15)
           (JB_3DPB:Dbox1:exe:AddFehlendeBloecke)
           )
          
          )
    ) 
  )
;;;Block aus CAD
(defun JB_3DPB:Dbox1:action:BlockAusCad ( / OBJ)
  (if (and(setq obj (car (entsel "\nPicken Sie einen Block mit mindestens 2 Attributen:")))
          (or (=(cdr(assoc 0(entget obj)))"INSERT")
              (alert "Das gepickte Objekt war kein Block."))
          (or
            (>=(length (JBf_list_att_aus_vla-blockdef (vla-get-effectivename(vlax-ename->vla-object obj))))2)
            (alert "Der Block muss mindestens 2 Atttribute enthalten.")
            )
          )
    (vla-get-effectivename(vlax-ename->vla-object obj)))
  )


;;;wenn Block gewählt
(defun JB_3DPB:Dbox1:action:b0-b1 ( / )
  (setq vla-attList(mapcar '(lambda(X)(vla-get-TagString X))
                     (JBf_list_att_aus_vla-blockdef BlockName))
        Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 BlockName "JB_1_b1")
        Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 (car vla-attList)"JB_1_p1")
        Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 (cadr vla-attList)"JB_1_p2")
        p1&Dbox1 nil p2&Dbox1 nil p1_sel&Dbox1 nil p2_sel&Dbox1 nil)
  (JB_3DPB:Dbox1:att:ini))
  
    
   
;;;Action (Variable global in Aufrufender Funktion)
(defun JB_3DPB:Dbox1:action (key / NAME X)

  (cond
    ((= key "JB_1_p1")
     (setq p1_sel&Dbox1 (atoi $value))
     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 (nth p1_sel&Dbox1 p1&Dbox1)"JB_1_p1"))
     )
    ((= key "JB_1_p2")
     (setq p2_sel&Dbox1 (atoi $value))
     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 (nth p2_sel&Dbox1 p1&Dbox1)"JB_1_p2"))
     )
    ((= key "JB_1_b0")
     (if(setq BlockName (JB_3DPB:Dbox2))
       (progn
         (JB_3DPB:Dbox1:action:b0-b1)
         (JB_3DPB:Dbox1:set)
         (JB_3DPB:Dbox1:mode)
         )
       )
     )

    ((= key "JB_1_b1")
     (JB_3DPB:Dbox1:get)
     (setq JB_3DPB$DCL$_1_po (done_dialog 11))
     )

    ((= key "JB_1_b2")
     (JB_3DPB:Dbox1:get)
     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 key "LastButton"))
     (setq JB_3DPB$DCL$_1_po (done_dialog 12))
     )
    ((= key "JB_1_b3")
     (JB_3DPB:Dbox1:get)
     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 key "LastButton"))
     (setq JB_3DPB$DCL$_1_po (done_dialog 13))
     )
    ((= key "JB_1_b4")
     (JB_3DPB:Dbox1:get)
     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 key "LastButton"))
     (setq JB_3DPB$DCL$_1_po (done_dialog 14))
     )

    ((= key "JB_1_b5")
     (JB_3DPB:Dbox1:get)
     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 key "LastButton"))
     (setq JB_3DPB$DCL$_1_po (done_dialog 15))
     )
    
    ((= key "cancel") ;;;Ende
    (JB_3DPB:Dbox1:get) 
     (setq JB_3DPB$DCL$_1_po (done_dialog 99))
     )
    )
    
)


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

    
;;;DBox1: setten
(defun JB_3DPB:Dbox1:set ( / SternString X)
  

  (JBf_Dcl:AddList:New "JB_1_p1" p1&Dbox1)
  (if p1_sel&Dbox1
    (set_tile "JB_1_p1" (itoa p1_sel&Dbox1)))
  
  (JBf_Dcl:AddList:New "JB_1_p2" p2&Dbox1)
  (if p2_sel&Dbox1
    (set_tile "JB_1_p2" (itoa p2_sel&Dbox1)))

  (mapcar '(lambda(X)(set_tile (strcat "JB_1_"(car X))(cadr X)))
    (list
      (list "t1" (cdr(assoc "JB_1_b1" Settings&dbox1)))
      (list "e1" (cdr(assoc "JB_1_e1" Settings&dbox1)))
      (list "e2" (cdr(assoc "JB_1_e2" Settings&dbox1)))
      (list "e3" (cdr(assoc "JB_1_e3" Settings&dbox1)))
      (list "e4" (cdr(assoc "JB_1_e4" Settings&dbox1))))))

;;;DBox1, moden
(defun JB_3DPB:Dbox1:mode ( / )
  (if (not (tblsearch "BLOCK" (cdr(assoc "JB_1_b1" Settings&dbox1))))
    (progn
      (mode_tile "JB_1_p1" 1)
      (mode_tile "JB_1_p2" 1)
      (mode_tile "JB_1_b2" 1)
      (mode_tile "JB_1_b3" 1)
      (mode_tile "JB_1_b4" 1)      
      (mode_tile "JB_1_b1" 2)
      (alert "Sie müssen einen Punktblock auswählen.")
      )
    (progn
      (mode_tile "JB_1_p1" 0)
      (mode_tile "JB_1_p2" 0)
      (mode_tile "JB_1_b2" 0)
      (mode_tile "JB_1_b3" 0)
      (mode_tile "JB_1_b4" 0)
      (mode_tile (cdr(assoc "LastButton" Settings&dbox1))2)
      )
    )
  (if error&dbox1
    (mode_tile error&dbox1 2)
    )
  )


;;;vla-List für 3D-Polylinien aus aws
(defun JB_3DPB:Dbox1:exe:vla-PlList (aws / N RETLIST VLA-OBJ)
  (setq n 0)
  (repeat (sslength aws)
    (setq vla-obj (vlax-ename->vla-object (ssname aws n)))
    (if (=(vla-get-Objectname vla-obj) "AcDb3dPolyline")
      (setq RetList (cons vla-obj RetList))
      )
    (setq n (+ n 1)))
  RetList)


;;;LW-Polylinien adden
;;;closedFlag :vlax-true oder :vlax-false
;;;koord als (apply 'append koord-List mit xy)
(defun JB_3DPB:DBox1:exe:pAuf3DPoly-p:AddLWPoly(koords layer closedFlag space / KOORDSARRAY vla-LwPoly)
  (setq KoordsArray (vlax-make-safearray vlax-vbDouble (cons 0  (-(length koords)1))))
  (vlax-safearray-fill KoordsArray koords)
  (setq vla-LwPoly(vla-addLightweightPolyline space KoordsArray))
  (vla-put-layer vla-LwPoly layer)
  (vla-put-closed vla-LwPoly closedFlag)
  vla-LwPoly
  )


;;;2D-LW-Poly als Hilfslinie
(defun JB_3DPB:DBox1:exe:LwPolyAdd (vla-3dPoly space / COORDS2D N VEKTOR VLA-LWPOLY)
  (setq n -1)
  (setq coords2d (vl-remove-if 'not
                   (mapcar '(lambda(X)
                              (setq n (+ n 1))
                              (if (/= n 2)
                                X
                                (progn
                                  (setq n -1)
                                  nil)))
                     (vlax-get vla-3dPoly 'Coordinates))))
  (setq vla-LwPoly (JB_3DPB:DBox1:exe:pAuf3DPoly-p:AddLWPoly
                     coords2d
                     (vla-get-layer vla-3dPoly)
                     (vla-get-closed vla-3dPoly)
                     space))
  (setq vektor (list (car coords2d)(cadr coords2d)0))
  (vla-move vla-LwPoly (vlax-3d-Point vektor)(vlax-3d-Point '(0 0 0)))
  (list vla-LwPoly vektor)
  )

;;;3D-Polylinie prüfen, ob 2D-Koordinate direkt drauf liegt, wenn ja, dann WeltKoord zurück
(defun JB_3DPB:DBox1:exe:pAuf3DPoly:p (vla-3dPoly pWelt space / PCLOSEST RETP VEKTOR VLA-LWPOLY)

  (setq vla-LwPoly(JB_3DPB:DBox1:exe:LwPolyAdd vla-3dPoly space)
        vektor (cadr vla-LwPoly)
        vla-LwPoly (car vla-LwPoly))
  
  (setq pWelt (mapcar '- pWelt vektor))
  (if (and(setq pClosest(vlax-curve-getClosestPointTo vla-LwPoly pWelt))
          (equal pWelt pClosest 0.0001))
    (setq RetP (mapcar '+ pClosest vektor))
    )
  (vla-delete vla-LwPoly)
  RetP)

;;;3D-Poly, Schnittpunkt mit Lini prüfen, dann sp zurückgeben
(defun JB_3DPB:DBox1:exe:Schnittpunkt:p (vla-3dPoly pWelt p1Welt space / RETP SP VEKTOR VLA-LWPOLY)

  (setq vla-LwPoly(JB_3DPB:DBox1:exe:LwPolyAdd vla-3dPoly space)
        vektor (cadr vla-LwPoly)
        vla-LwPoly (car vla-LwPoly))
  (setq pWelt (mapcar '- pWelt vektor)
        p1Welt (mapcar '- p1Welt vektor))

  (entmake (list (cons 0 "LINE")(cons 10 pWelt)(cons 11 p1Welt)))
  (if (setq sp (car(JBf_List:ObjSchnitt (entlast)(vlax-vla-object->ename vla-LwPoly))))
    (setq RetP (mapcar '+ sp vektor))
    )
  (vla-delete (vlax-ename->vla-object(entlast)))
  (vla-delete vla-LwPoly)
  
  RetP)

;;;Coords 3D-Poly in List
(defun JB_3DPB:DBox1:exe:3dPoly:coordList (vla-3DPoly / N SUB X)
  (setq n -1)
  (vl-remove-if 'not
                 (mapcar '(lambda(X)
                            (setq n (+ n 1))
                            (if (= n 2)
                              (progn
                                (setq Sub (cons X Sub))
                                (setq n -1)
                                (Setq X (reverse Sub))
                                (setq Sub nil)
                                X)
                              (progn
                                (setq Sub (cons X Sub))
                                nil))
                            )
                   (vlax-get vla-3DPoly 'Coordinates)))
  )
  

;;;Punkte in 3D-Poly einfügen
(defun JB_3DPB:DBox1:exe:PointAdd (vla-PlList / COORDS DISTLIST DONE N NNEW PLSUB PNEW STATENDE STATSTART X)
  
  (vl-remove-if '(lambda(X)(caddr X))
  (mapcar '(lambda(PlSub)
             (Setq Done nil)
             (setq coords(JB_3DPB:DBox1:exe:3dPoly:coordList (car PlSub)))
             
             
             (setq DistList(mapcar '(lambda(X)
                                      (list "3D"
                                            (distance (JBf_list_xyz->xy0 X)(cadr PlSub))
                                            (vlax-curve-getDistAtPoint (car PlSub)X)
                                            X))
                             coords)
                             )

             
             (setq DistList (vl-sort
                              DistList
                              '(lambda(e1 e2)(< (cadr e1)(cadr e2)))))
             
             (if (not(equal(cadr (car DistList))0.0 0.00001));;;wenn nicht am Start, Ende oder auf vorhandenem Stützpunkt
               (progn
                 (setq StatEnde nil)
                 (setq StatStart (car DistList))
                 (mapcar '(lambda(X)
                            (if (and (not StatEnde)(not(equal (cadr StatStart)(cadr X)0.00001)))
                              (if (equal (/ (- (car(cadddr X))(car(cadddr StatStart)))
                                            (- (cadr(cadddr X))(cadr(cadddr StatStart))))
                                         (/ (- (car(cadr PlSub))(car(cadddr StatStart)))
                                            (- (cadr(cadr PlSub))(cadr(cadddr StatStart))))0.00001)
                                (setq StatEnde X))
                              )
                            )
                   DistList)

                 (if (and StatStart StatEnde)
                   (progn
                     (setq StatStart (caddr StatStart)
                           statEnde (caddr statEnde))

                     (if (> StatStart StatEnde)
                       (setq StatStart (list StatEnde StatStart)
                             StatEnde (cadr StatStart)
                             StatStart (car StatStart))
                       )
                     (setq DistList (vl-sort DistList '(lambda(e1 e2)(< (caddr e1)(caddr e2)))))
                     (setq n -1)
                     (setq DistList (apply 'append
                                           (vl-remove-if 'not
                                         (mapcar '(lambda(X)
                                                    (setq n (+ n 1))
                                                    (cond((equal (caddr X)StatStart 0.00001)
                                                          (list X
                                                                (list "New" 0.0 nil (cadr PlSub))
                                                                (nth (+ n 1)DistList)))
                                                         ((not(equal (caddr X)StatEnde 0.00001))
                                                          (list X))))DistList))))
                     (if (member "New" (mapcar 'car DistList))
                       (setq nNew (-(length DistList)(length (member "New" (mapcar 'car DistList)))))
                       (setq nNew nil))

                     (if nNew
                       (progn
                         (setq n -1)
                         (setq coords (mapcar '(lambda(X)
                                                 (setq n (+ n 1))
                                                 (if (= n nNew)
                                                   (setq pNew(list (car(cadddr X))(cadr(cadddr X))
                                                         (+(*(/(-(caddr(cadddr(nth (+ nNew 1)DistList)))
                                                                 (caddr(cadddr(nth (- nNew 1)DistList))))
                                                               (distance(JBf_list_xyz->xy0(cadddr(nth (- nNew 1)DistList)))
                                                                 (JBf_list_xyz->xy0(cadddr(nth (+ nNew 1)DistList)))))
                                                             (distance(JBf_list_xyz->xy0(cadddr(nth (- nNew 1)DistList)))
                                                               (JBf_list_xyz->xy0(cadddr(nth nNew DistList)))))
                                                           (caddr(cadddr(nth (- nNew 1)DistList))))))
                                                   (cadddr X)))DistList))
                         (vlax-put (car PlSub) 'Coordinates (apply 'append coords))
                         (JB_3DPB:DBox1:exe:BlockAdd pNew)
                         (setq DONE 'T))
                       )
                     )
                   )
                 )
               )

             (list (car PlSub)(cadr PlSub)Done)
        
             )vla-PlList))
  )

;;;Nummer hochzählen, wenn bereits vorhanden
(defun JB_3DPB:DBox1:exe:BlockAdd:Nummer ( / NR NRALT)
  (setq nrAlt(cdr(assoc "JB_1_e4" Settings&dbox1)))
  (setq Nr nrAlt)
  (while(member Nr Pnr&DBox1)
    (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 (setq Nr(itoa(+ 1(atoi Nr))))"JB_1_e4"))
    )
  (if (/= Nr nrAlt)
    (alert (strcat "Es wird die nächste freie Punktnummer verwendet: " Nralt " -> " Nr))
    )
  )
    
;;;Punktblöcke einfügen
(defun JB_3DPB:DBox1:exe:BlockAdd (p / W)
  (if (not(tblsearch "LAYER" (cdr(assoc "JB_1_e2" Settings&dbox1))))
    (entmake (list'(0 . "LAYER")
                  '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") (cons 2 (cdr(assoc "JB_1_e2" Settings&dbox1)))
                  '(70 . 0) '(62 . 7) '(6 . "Continuous") '(290 . 1) '(370 . -3) )))
  (setq w (angle (trans '(0 0 0)1 0)(trans '(1 0 0)1 0)))

  (JB_3DPB:DBox1:exe:BlockAdd:Nummer)
  
  (JBf_VlaAdd:AddBlock
    (cdr(assoc "JB_1_b1" Settings&dbox1))
    (vlax-3d-point p)
    (atof(cdr(assoc "JB_1_e1" Settings&dbox1)))
    (cdr(assoc "JB_1_e2" Settings&dbox1)) w (vlax-3d-point '(0 0 1))
      (list (list (cdr(assoc "JB_1_p1" Settings&dbox1))
                  (list(list 'TextString (cdr(assoc "JB_1_e4" Settings&dbox1)))))
	   (list (cdr(assoc "JB_1_p2" Settings&dbox1))
	     (list(list 'TextString (rtos(caddr p)2 (atoi(cdr(assoc "JB_1_e3" Settings&dbox1)))))))
	   )
       'T;;;FeldBlockerFlag
      )

  (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 (itoa(+ 1 (atoi(cdr(assoc "JB_1_e4" Settings&dbox1)))))"JB_1_e4"))
  )


;;;Einzelpunkte
(defun JB_3DPB:Dbox1:exe:Einzel( / AWS DO P PWELT SPACE VLA-PLLIST X DoneList)
  (setq Do 'T)
  (setq space(if (= 1 (getvar "CVPORT"))
	   (vla-get-PaperSpace (vla-get-activedocument (vlax-get-acad-object)))
	   (vla-get-ModelSpace (vla-get-activedocument (vlax-get-acad-object)))
	)
        )
  (while (and Do(setq p (getpoint "\nPicken Sie einen Einfügepunkt (ENTER=Ende):")))
    (if (and(setq aws (ssget "_c" (mapcar '- p '(0.1 0.1 0.0))(mapcar '+ p '(0.1 0.1 0.0))
                         (list (cons 0 "POLYLINE")(cons 410(getvar "CTAB")))))
            (setq pWelt (JBf_list_xyz->xy0(trans p 1 0)))
            (setq vla-PlList (JB_3DPB:Dbox1:exe:vla-PlList aws))
            (setq vla-PlList (vl-remove-if 'not
                               (mapcar '(lambda(X)
                                          (if(setq p(JB_3DPB:DBox1:exe:pAuf3DPoly:p X pWelt space))
                                            (list X p))
                                          )
                                 vla-PlList))
                  )
            )
      (if (setq DoneList(JB_3DPB:DBox1:exe:PointAdd vla-PlList))
        (if (=(length DoneList)1)
          (alert "Es konnte bei einer 3D-Polylinie kein Stützpunkt eingefügt werden.")
          (alert (strcat "Es konnte bei "(itoa(length DoneList))" 3D-Polylinien kein Stützpunkte eingefügt werden."))
          )
        )
      (if (not p)
        (setq Do nil)
        )
      )
    )
  )


(defun JB_3DPB:Dbox1:exe:Schnittlinie( / AWS DO P P1 PWELT P1WELT SPACE VLA-PLLIST X DoneList)
  (setq Do 'T)
  (setq space(if (= 1 (getvar "CVPORT"))
	   (vla-get-PaperSpace (vla-get-activedocument (vlax-get-acad-object)))
	   (vla-get-ModelSpace (vla-get-activedocument (vlax-get-acad-object)))
	)
        )
  (while (and Do(setq p (getpoint "\nPicken Sie den ersten Punkt der Schnittlinie (ENTER=Ende):"))
             (setq p1 (getpoint p "\nPicken Sie den zweiten Punkt der Schnittlinie (ENTER=Ende):")))
    (if (and(setq aws (ssget "_f" (list p p1)
                         (list (cons 0 "POLYLINE")(cons 410(getvar "CTAB")))))
            (setq pWelt (JBf_list_xyz->xy0(trans p 1 0)))
            (setq p1Welt (JBf_list_xyz->xy0(trans p1 1 0)))
            
            (setq vla-PlList (JB_3DPB:Dbox1:exe:vla-PlList aws))
            (setq vla-PlList (vl-remove-if 'not
                               (mapcar '(lambda(X)
                                          (if(setq p(JB_3DPB:DBox1:exe:Schnittpunkt:p X pWelt p1Welt space))
                                            (list X p))
                                          )
                                 vla-PlList))
                  )
            )
      (if (setq DoneList(JB_3DPB:DBox1:exe:PointAdd vla-PlList))
        (if (=(length DoneList)1)
          (alert "Es konnte bei einer 3D-Polylinie kein Stützpunkt eingefügt werden.")
          (alert (strcat "Es konnte bei "(itoa(length DoneList))" 3D-Polylinien kein Stützpunkte eingefügt werden."))
          )
        )
      (if (not p1)
        (setq Do nil)
        )
      )
    (setq p nil p1 nil)
    )
  )

;;;Polylinien aussondern, die nicht zur Blockkoord passen
(defun JB_3DPB:Dbox1:exe:vla-PlList:P (vla-PlList p / COORDS Y X)
  (vl-remove-if 'not(mapcar '(lambda(X)
             (setq coords(JB_3DPB:DBox1:exe:3dPoly:coordList X))
             (if (=(length(vl-remove-if '(lambda(Y)
                                  (not(equal (distance Y p)0.0 0.00001))
                                  )
                   coords))1)
               X))vla-PlList))
  )
      
;;;Punktblöcke entfernen
(defun JB_3DPB:Dbox1:exe:Bloecke:entf ( / AWS AWSP COORDS COORDS1 DO N P VLA-PLLIST X)
  (setq Do 'T)
  (while Do
    (setq aws nil)
    (if (and (princ "\nWählen Sie 3D-Punktblöcke (ENTER=Ende):")
          (setq aws (ssget  
                         (list (cons 0 "INSERT")(cons 2 (cdr(assoc "JB_1_b1" Settings&dbox1)))(cons 410(getvar "CTAB")))))
             )
      (progn
        (setq n 0)
        (repeat (sslength aws)
          (setq p (trans(vlax-get (vlax-ename->vla-object(ssname aws n))'InsertionPoint)0 1))
          (if (and(setq awsP(ssget "_c" (mapcar '- p '(0.1 0.1 0.0))(mapcar '+ p '(0.1 0.1 0.0))
                                   (list (cons 0 "POLYLINE")(cons 410(getvar "CTAB")))))
                  (setq vla-PlList (JB_3DPB:Dbox1:exe:vla-PlList awsP))
                  (setq vla-PlList (JB_3DPB:Dbox1:exe:vla-PlList:P vla-PlList (trans p 1 0))))
            (mapcar '(lambda(X)
                       (setq coords(JB_3DPB:DBox1:exe:3dPoly:coordList X))
                       (setq coords1(vl-remove-if '(lambda(Y)
                                  (equal (distance Y p)0.0 0.00001)
                                                    )
                                     (reverse(cdr(reverse(cdr coords))))))
                       (if (< (length Coords1)(-(length Coords)2))
                         (progn
                           (vlax-put X 'Coordinates (apply 'append (append (list(car coords)) coords1 (list(last coords)))))
                           (vla-delete (vlax-ename->vla-object(ssname aws n)))
                           )
                           )
                       )
              vla-PlList)
            )
          (setq n (+ n 1))
          )
        )
      )
        
      (if (not aws)
        (setq Do nil)
        )
      )
    
    )

;;;Punktblöcke suchen auf 3D-Polylinie
(defun JB_3DPB:Dbox1:exe:AddFehlendeBloecke:Done (vla-PlList / AWS COORDS MAXCOORDS MINCOORDS N P X)
  (mapcar '(lambda(X)
             (setq coords(JB_3DPB:DBox1:exe:3dPoly:coordList X))
             (setq mincoords (list (apply 'min (mapcar 'car coords))
                                   (apply 'min (mapcar 'cadr coords))))
             (setq maxcoords (list (apply 'max (mapcar 'car coords))
                                   (apply 'max (mapcar 'cadr coords))))
             (vla-zoomwindow(vlax-get-acad-object) (vlax-3d-point (mapcar '- mincoords '(0.1 0.1 0.0)))(vlax-3d-point (mapcar '+ maxcoords '(0.1 0.1 0.0))))
             (if (setq aws(ssget "_c" (trans(mapcar '- mincoords '(0.1 0.1 0.0))0 1)(trans(mapcar '+ maxcoords '(0.1 0.1 0.0))0 1)
                         (list (cons 0 "INSERT")(cons 2 (cdr(assoc "JB_1_b1" Settings&dbox1)))(cons 410(getvar "CTAB")))))
               (progn
                 (setq n 0)
                 (repeat (sslength aws)
                   (setq p (vlax-get (vlax-ename->vla-object(ssname aws n))'InsertionPoint))
                   (setq coords (vl-remove-if '(lambda(Y)(equal (distance p Y)0.0 0.00001))coords))
                   (setq n (+ n 1)))
                 )
               )
             (mapcar ' JB_3DPB:DBox1:exe:BlockAdd coords)
             )
    vla-PlList)
  )
                   


;;;Fehlende Punktblöcke hinzufügen
(defun JB_3DPB:Dbox1:exe:AddFehlendeBloecke ( / AWS DO SPACE VLA-PLLIST)
  (setq Do 'T)
  (while Do
    (setq aws nil)
    (if (and (princ "\nWählen Sie 3D-Polylinien (ENTER=Ende):")
             (setq aws (ssget  (list (cons 0 "POLYLINE")(cons 410(getvar "CTAB")))))
             (setq vla-PlList (JB_3DPB:Dbox1:exe:vla-PlList aws)))
      (JB_3DPB:Dbox1:exe:AddFehlendeBloecke:Done vla-PlList)
      
    (if (not aws)
        (setq Do nil)
        )
      )
    )
  )
  
       

  
                     


;;;DBox2, setten
(defun JB_3DPB: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)))
)

;;;DBox2, moden
(defun JB_3DPB:Dbox2:mode ( / )
  (if l1&Dbox2
    (mode_tile "JB_2_l1" 2)
    (progn
      (mode_tile "JB_2_l1" 1)
      (mode_tile "accept" 1)
      (alert "In der aktuellen Zeichnung ist kein Block mit mindestens 2 Attributen vorhanden.")
      )
    )
  )
     





;;;BlockListe mit mindesten 2 Attributen
(defun JB_3DPB:Dbox2:BlockList:Ini ( / RETLIST)
  (vlax-for ITEM
	   (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object)))
    (if (>=(length (JBf_list_att_aus_vla-blockdef (vla-get-name ITEM)))2)
      (setq RetList (cons (vla-get-name ITEM)RetList))
      )
    )
  (if RetList
    (setq l1&DBox2 (vl-sort RetList '(lambda(e1 e2)(< e1 e2)))
          l1_sel&Dbox2 0)
    )
  )
;;;DBox2 => Farbe
(defun JB_3DPB:Dbox2 ( / l1&Dbox2 l1_sel&Dbox2 DclId ok A Blockname)

  (JB_3DPB:Dbox2:BlockList:Ini)

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

    (setq DclId (JBf_Dcl:Load_dialog JB_3DPB_$DCL$_File "JB_3DPB_2" JB_3DPB$DCL$_2_po))

    (JB_3DPB:Dbox2:set)
    (JB_3DPB:Dbox2:mode)
    
    (mapcar (function (lambda (A) (action_tile A (strcat "(JB_3DPB:Dbox2:action \"" A "\")"))))
            '(
               "JB_2_l1"
               "accept" "cancel"
             )
    )

    (setq ok (start_dialog))
    (unload_dialog DclId)


    (if (= ok 1)
      (setq BlockName (nth l1_sel&Dbox2 l1&Dbox2))
      )
  )
 BlockName)


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

  (cond
    ((= key "JB_2_l1")
     (setq l1_sel&Dbox2 (atoi $value))
     )
    ((= key "accept");;;Auswahl mit OK abschließen     
     (setq JB_3DPB$DCL$_2_po (done_dialog 1))
    )
    ((= key "cancel")    ;;;Abbrechen
     (setq JB_3DPB$DCL$_2_po (done_dialog 99))
    )

  )
)

         
;;;DCL-schreiben
(defun JB_3DPB:dcl:Write ( / file)  
  (if (and (setq JB_3DPB_$DCL$_File (vl-filename-mktemp (strcat "3DPB.dcl")))
           (setq file (open JB_3DPB_$DCL$_File "w"))
      )
    (progn
      (mapcar '(lambda (A)
                       (write-line A file)
               )
              (mapcar '(lambda (A)
                               (strcat "\n" A)
                       )
              (list
                "//Hauptdialog"
                "JB_3DPB_1: dialog {label= \"3D-Polylinien - Punktblöcke\";	 "
                ":boxed_column {label = \"Punktblock\";"
                ":row{"
                ":button  {key = \"JB_1_b0\"; label = \"aus &Liste...\"; fixed_width = true;}"
                ":button  {key = \"JB_1_b1\"; label = \"aus &CAD<\"; fixed_width = true;}"
                ":text {key = \"JB_1_t1\"; label = \"MeinBlock\";width = 28;}}"
                ":popup_list {key = \"JB_1_p1\"; label = \"Nummer\";edit_width = 25;}"
                ":popup_list {key = \"JB_1_p2\"; label = \"Hoehe\";edit_width = 25;}"
                "}"
                ":boxed_column {label = \"Punktblock-Optionen\";"
                ":edit_box {key = \"JB_1_e1\"; label = \"Faktor\";edit_width= 25;}"
                ":edit_box {key = \"JB_1_e2\"; label = \"Einfügelayer\";edit_width= 25;}"
                ":edit_box {key = \"JB_1_e3\"; label = \"Nachkommastellen\";edit_width= 25;}"
                ":edit_box {key = \"JB_1_e4\"; label = \"Punktnummer\";edit_width= 25;allow_accept=true;}"
                "}"
                ":boxed_column {label = \"Aufgaben\";"
                ":row{"
                ":button {key = \"JB_1_b2\"; label = \"Ein&zelpunkte<\";}"
                ":button {key = \"JB_1_b3\"; label = \"&Linienschnittpunkte<\";}}"
                ":button {key = \"JB_1_b5\"; label = \"&Fehlende Punktblöcke auf Stützpunkte<\";}"
                ":button {key = \"JB_1_b4\"; label = \"Punktblöcke entfe&rnen<\";}"
                "}"
                ":row{fixed_width = true;alignment = centered;"
                ":retirement_button {label = \"&Ende\"; key= \"cancel\"; fixed_width = true;is_cancel=true;}"
                "}"
                "}"
                "JB_3DPB_2: dialog {label= \"Blockliste\";"
                ":boxed_column {label = \"Bitte auswählen\";"
                ":list_box {key = \"JB_2_l1\";width= 50; height =28;allow_accept=true;}"
                "}"
                "ok_cancel;}"


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


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

;;;Att_liste aus vla-object
(defun JBf_list_att_aus_vla-blockdef (name / LISTE)
  (if name
  (if (tblsearch "BLOCK" name)
    (progn
  (vlax-for ITEM
    (vla-item
      (vla-get-blocks
        (vla-get-activedocument
          (vlax-get-acad-object)))name)
    (if (= (vla-get-Objectname ITEM) "AcDbAttributeDefinition")
      (setq liste (cons ITEM liste))))
  (reverse liste)))))

(defun JBf_list_xyz->xy0 (list_xyz / )
  (if (=(length list_xyz)2)
    (reverse(cons 0.0 (reverse list_xyz)))
    (reverse(cons 0.0 (cdr(reverse list_xyz)))))
  )


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





;;;--------------------------------------------------------------------------------------------------------
;;;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|3D-Polylinien - Punktblöcke.                                |"
          "\n|------------------------------------------------------------|"
          "\n|erstellt durch Bosse-engineering - www.bosse-engineering.com|"
          "\n|------------------------------------------------------------|"
          "\n|Befehlszeilenaufruf: 3DPB                                   |"
          "\n|++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++|"
          )
       )
(princ)










