
;;;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: PMS - Es werden auf vorhandene Polyliniezüge Multilinienstempel angewendet, d.h., eine vor- 
;;;definierte Multiliniestruktur über versetzte Polylinien wird erstellt. Diese zusätzlichen Linien können 
;;;z.B. vor Änderungen an der Führungspolylinie aus und dann in aktueller Fom wieder eingeschaltet werden. 
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;;;globale Variablen:										   	   
;;;- JB_PMS$DCL$_[x]_po (Positionen der Dialogfenster)							   
;;;- JB_PMS_$DCL$_File (temporäre DCL-Datei)								   
;;;                                                                              Jörn Bosse, 06.04.23	   
;;;--------------------------------------------------------------------------------------------------------



;;;aufrufenden Funktionen
(defun c:PMS ( / )
  (JB_PMS)
  )

;;;Intro
(defun JB_PMS:Intro (str / )
  (princ "\nerstellt durch Bosse-engineering - www.bosse-engineering.com\n")
  (princ "\n----------------------PMS(1.0), 06.04.23---------------------")
  (princ str)
  (princ "\n-------------------------------------------------------------")
  )


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

;;;Variablenliste
(defun JB_PMS:v_liste ( / )
  '(
     ( "DboxSettings" . (
                         ( "Dbox1" .
                            (
                             ( "JB_1_p1" . (
                                            ("<unbenannt>" .
                                             (
                                              (
                                               (0 ((0 . "LAYER") (100 . "AcDbSymbolTableRecord") (100 . "AcDbLayerTableRecord") (2 . "0") (70 . 0) (62 . 7) (6 . "Continuous") (290 . 1) (370 . -3)))
                                               (1 ((0 . "LTYPE") (100 . "AcDbSymbolTableRecord") (100 . "AcDbLinetypeTableRecord") (2 . "Continuous") (70 . 0) (3 . "Solid line") (72 . 65) (73 . 0) (40 . 0.0)))
                                               (2 "0.0")
                                               (3 "0.0")
                                               )
                                              )
                                             )
                                            )
                              );;;MultiLinienListe:(0 LayerList, 1 Ltype-List, 2 = PL-Breite, 3 = Abstand
                             ( "LastName" . "<unbenannt>")
                             ( "JB_1_to1" . "1")
                             ( "LastButton" . "accept")
                             )
                          )
                          
                         ( "Dbox2" .
                            (
                             ( "JB_3_e1" . "0.0");;;Letzte Breite
                             ( "JB_3_t2" . "*");;;Filter für Layernamen
                             ))
                         ))))


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

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

  (setq pfad_ini (JB_PMS: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_PMS:v_liste))pfad_ini nil))
  
  (vla-startundomark (vla-get-activedocument(vlax-get-acad-object)))
  (JBf_init
    '(("CMDECHO" 0)
      ("DIMZIN" 3)
      ))
  
  
  (JB_PMS:Intro "\nPMS: Multilinienstempel für Polylinien.")

  
  

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

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


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

;;;alle Layer aus v_liste erstellen, sofern in aktueller Zeichnung noch nicht vorhanden
(defun JB_PMS:Layer:Entmake (subList /)
  (if (not (tblsearch "LTYPE" (cdr (assoc 2 (cadr (assoc 1 subList))))))
    (entmake (cadr (assoc 1 subList)))
  )
  (if (not (tblsearch "LAYER" (cdr (assoc 2 (cadr (assoc 0 subList))))))
    (entmake (cadr (assoc 0 subList)))

  )

)

;;;Table-Liste für v_liste => muss exisitieren, keine Prüfung
(defun JB_PMS_tblList4v_liste (tblName name / )
  (vl-remove-if '(lambda (X)
                         (or (member (car X)
                                     '(-1 5 102 330 390 347)
                             )
                             (= (type (cdr X)) 'ENAME)
                         )
                 )
                (entget (tblobjname tblName name))
  )
)




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

    (setq DclId (JBf_Dcl:Load_dialog JB_PMS_$DCL$_File "JB_PMS_1" JB_PMS$DCL$_1_po))

    (JB_PMS:Dbox1:set)
    (JB_PMS:Dbox1:mode)
    
    
    (mapcar '(lambda (A) (action_tile A (strcat "(JB_PMS:Dbox1:action \"" A "\")")))
            '("JB_1_b10" "JB_1_b11" "JB_1_b12" "JB_1_b13" 
              "JB_1_b1" "JB_1_b2" "JB_1_b3"
              "JB_1_l1" "JB_1_p1"
              "JB_1_b4" "JB_1_b5"
              "JB_1_to1"
	      "accept" "cancel"
             )
    )
    (setq ok (start_dialog))
    (unload_dialog DclId)
    
    (cond ((= ok 99) ;;;Ende
           (setq v_liste (JB_PMS:v_liste:DboxSettings:put "Dbox1" Settings&dbox1 v_liste))
           (JBf_SIC:sichern v_liste pfad_ini nil)
           )
          ((= ok 1);;;Stempel anbringen
           (JB_PMS:Dbox1:anbringen nil)
           )
          ((= ok 14);;;Stempel anbringen
           (JB_PMS:Dbox1:entfernen))
          ((= ok 15);;;Stempel wieder herstellen
           (JB_PMS:Dbox1:restore))
          )
    ) 
  )


;;;Polylinien wieder herstellen
(defun JB_PMS:Dbox1:restore ( / AWS AWSDELETE HANDLELIST N SEITENFAKTOR VLA-OBJ VLA-OBJLIST HandleList)
  (if (and (princ "\nWählen Sie Polylinien (ENTER=> Menü):")
           (setq aws (ssget (list (cons 0 "LWPOLYLINE,POLYLINE"))))
           )
    (progn
      (setq n 0)
      (setq awsDelete (ssadd))
      (repeat (sslength aws)
        (setq HandleList nil)
        (setq vla-obj (vlax-ename->vla-object (ssname aws n)))
        (if (and (JBf_list_xdaten_read:Vla "JB_PMS_Achse" vla-obj nil)
                 (JBf_list_xdaten_read:Vla "JB_PMS_Lines" vla-obj nil)
                 (setq SeitenFaktor(JBf_list_xdaten_read:Vla "JB_PMS_SeitenFaktor" vla-obj 1040))                 
                 (setq HandleList(JBf_list_xdaten_read:Vla "JB_PMS_Handles" vla-obj nil))
                 (not(vl-remove-if (function(lambda(X)(or (= (vla-get-Handle vla-obj)X)(not(entget(handent X))))))(mapcar 'cdr HandleList))))
          (setq vla-objList (cons (list vla-obj nil SeitenFaktor)vla-objList))
          )
        (setq n (+ n 1))
        )
      )
    )
  (if vla-objList (JB_PMS:Dbox1:anbringen vla-objList)))
    
  

;;;Polylinien entfernen
(defun JB_PMS:Dbox1:entfernen( / AWS AWSDELETE HANDLELIST N VLA-OBJLIST X AchsDaten SubList)
  (if (and (princ "\nWählen Sie Polylinien (ENTER=> Menü):")
           (setq aws (ssget (list (cons 0 "LWPOLYLINE,POLYLINE"))))
           )
    (progn
      (setq n 0)
      (setq awsDelete (ssadd))
      (repeat (sslength aws)
        (setq HandleList nil)
        (setq vla-obj (vlax-ename->vla-object (ssname aws n)))
        (if (and (JBf_list_xdaten_read:Vla "JB_PMS_Lines" vla-obj nil)
                 (JBf_list_xdaten_read:Vla "JB_PMS_SeitenFaktor" vla-obj nil)
                 (setq HandleList(JBf_list_xdaten_read:Vla "JB_PMS_Handles" vla-obj nil)))
          (progn
            (if(setq AchsDaten(JBf_list_xdaten_read:Vla "JB_PMS_Achse" vla-obj 1000));;;dann Achse wieder herstellen
              (progn
                (setq subList (read AchsDaten))
                (JB_PMS:Layer:Entmake subList)
                (vla-put-layer vla-obj (cdr (assoc 2 (cadr (assoc 0 subList)))))
                (vla-put-constantwidth vla-obj (atof (cadr (assoc 2 subList))))
                (vla-update vla-obj))
              )
                            
            (mapcar '(lambda(X)
                       (if (/=(vla-get-handle vla-obj)X)
                         (if (and (handent X)
                                  (entget (handent X))
                                  )
                           (ssadd(handent X)awsDelete)
                           
                         )
                         )
                       )
              (mapcar 'cdr HandleList)))
          )
        (setq n (+ n 1))
        )
      
    (JBf_aws:Vla-DeleteRefresh awsDelete)
      )
    )
    
  )


;;;Vla-ObjList Pick
(defun JB_PMS:Dbox1:vla-objList:Pick ( / DO OBJ P RETLIST VLA-OBJ)
  (setq Do 'T)
  (while Do
    (if (and(setq obj (entsel "\nPicken Sie eine Polylinie (ENTER=>Menü):"))
            (setq vla-obj (vlax-ename->vla-object (car obj)))
            (setq p (trans (cadr obj)1 0))
            (or(member (vla-get-Objectname vla-obj) '("AcDb2dPolyline" "AcDbPolyline"))
               (alert "Das gepickte Objekt war keine gültige Polylinie.")))
      (setq RetList (list (list vla-obj p)nil)
            Do nil)
      (if (not obj) (setq Do nil)))
    )
  RetList)

;;;Vla-objList aus AWS
(defun JB_PMS:Dbox1:vla-objList:ssget:vla-objList (aws / N VLA-OBJLIST)
  (setq n 0)
  (repeat (sslength aws)
    (setq vla-objList (cons (list (vlax-ename->vla-object(ssname aws n))(car (JBf_VlaObjects:GetKoord (vlax-ename->vla-object(ssname aws n))))nil)vla-objList))
    (setq n (+ n 1))
    )
  vla-objList)

;;;Polylinie per AWS
(defun JB_PMS:Dbox1:vla-objList:ssget( / AWS RETLIST)
  (if (and (princ "\nWählen Sie Polylinien (ENTER=> Menü):")
           (setq aws (ssget (list (cons 0 "LWPOLYLINE,POLYLINE"))))
           (setq RetList (JB_PMS:Dbox1:vla-objList:ssget:vla-objList aws)))
  RetList)
  )


;;;Offset gecatcht
(defun JB_PMS:Dbox1:anbringen:vla-offset (vla-obj l / )
  (car(vlax-safearray->list(vlax-variant-value(vla-offset vla-obj l))))
)

;;;Positiv oder Negativ-Faktor bezgl. PolylinieRichtung
(defun JB_PMS:Dbox1:anbringen:SeitenFaktor (vla-obj p / L NEXTP STAT)
  (if (and p
           (setq NextP (vlax-curve-getClosestPointTo vla-obj p))
           (setq stat (vlax-curve-getDistAtPoint vla-obj NextP))
           (setq l (vla-get-length vla-obj))
           )
    (if (< stat (/ l 2.0));;;dann näher zum Beginn
      1.0
      -1.0
      )
    1.0
    )
  )
  

;;;Anbringen von Offset_polys
(defun JB_PMS:Dbox1:anbringen (vla-objList / DO SEITENFAKTOR SUBLIST SUBLISTACHSE SUBLISTNEU VLA-OBJ-OFFSET X NewIdList)
  (setq Do 'T)
  (while Do
    (if
      (or vla-objList
          (if (=(cdr(assoc "JB_1_to1" Settings&dbox1)) "1");;Picken
            (setq vla-objList (JB_PMS:Dbox1:vla-objList:Pick))
            (setq vla-objList (JB_PMS:Dbox1:vla-objList:ssget))
            )
          )
      (progn
        (mapcar '(lambda (subList)
                   (JB_PMS:Layer:Entmake subList)
                   )
          (cdr(nth p1_sel&Dbox1 p1&Dbox1))
          )

        (mapcar '(lambda(X)
                   (setq SeitenFaktor(JB_PMS:Dbox1:anbringen:SeitenFaktor (car X)(cadr X)))
                   (setq subListNeu nil)
                   (setq NewIdList nil)
                   (mapcar '(lambda (subList)
                              (setq subListAchse nil)
                              
                              (if
                                (if (=(atof (cadr (assoc 3 subList)))0.0);;;dann Kopie und kein Offset
                                  (progn
                                    (setq subListAchse
                                           (list
                                             (list 0 (JB_PMS_tblList4v_liste "LAYER" (vla-get-layer (car X))))
                                             (list 1 (JB_PMS_tblList4v_liste "LTYPE" (vla-get-lineType(vla-item(vla-get-layers(vla-get-activedocument(vlax-get-acad-object)))(vla-get-layer(car X))))))
                                             (list 2 (rtos(vla-get-Constantwidth (car X))2 6))
                                             (list 3 "0.0")))
                                    (setq vla-obj-Offset(car X))
                                    (vla-put-layer vla-obj-Offset (cdr (assoc 2 (cadr (assoc 0 subList)))))
                                    (vla-put-constantwidth vla-obj-Offset (atof (cadr (assoc 2 subList))))
                                    (vla-update vla-obj-Offset)
                                    (JBf_list_xdaten_append:vla "JB_PMS_Achse" (car X)(list (cons 1000 (vl-prin1-to-string subListAchse))))
                                    'T)

                                  (not (vl-catch-all-error-p
                                         (setq vla-obj-Offset (vl-catch-all-apply 'JB_PMS:Dbox1:anbringen:vla-offset
                                                                (list (car X) (* SeitenFaktor(atof (cadr (assoc 3 subList)))))
                                                                )
                                               )
                                         )
                                       )
                                  )
                              (progn
                                (vla-put-layer vla-obj-Offset (cdr (assoc 2 (cadr (assoc 0 subList)))))
                                (vla-put-constantwidth vla-obj-Offset (atof (cadr (assoc 2 subList))))
                                (vla-update vla-obj-Offset)
                                
                                (setq subListNeu (cons
                                                   (list
                                                     (list 0 (JB_PMS_tblList4v_liste "LAYER" (vla-get-layer vla-obj-Offset)))
                                                     (list 1 (JB_PMS_tblList4v_liste "LTYPE" (vla-get-lineType(vla-item(vla-get-layers(vla-get-activedocument(vlax-get-acad-object)))(vla-get-layer vla-obj-Offset)))))
                                                     (list 2 (rtos(vla-get-Constantwidth vla-obj-Offset)2 6))
                                                     (if subListAchse (assoc 3 subListAchse)(assoc 3 subList))
                                                     )subListNeu))
                                (setq NewIdList (cons (vla-get-handle vla-obj-Offset)NewIdList)))
                                                   
                               
                              )
                            )
                   (cdr(nth p1_sel&Dbox1 p1&Dbox1)))
                   (JBf_list_xdaten_append:vla "JB_PMS_SeitenFaktor" (car X)(list (cons 1040 SeitenFaktor)))
                   (JBf_list_xdaten_append:vla "JB_PMS_Lines" (car X)(mapcar '(lambda(Y)(cons 1000 (vl-prin1-to-string Y)))(reverse subListNeu)))
                   (JBf_list_xdaten_append:vla "JB_PMS_Handles" (car X)(mapcar '(lambda(Y)(cons 1005 Y))(reverse NewIdList)))
                 )
        vla-objList)
      (setq Do nil)
      )
    )
  )
  )
      




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

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

;;;DBox1, Eigenschaft löschen
(defun JB_PMS:Dbox1:action:b3 ( / N X)
  (setq n -1)
  (setq l1&Dbox1
         (vl-remove-if 'not
           (mapcar '(lambda(X)
                      (setq n (+ n 1))
                      (if (/= n l1_sel&Dbox1)
                        X))l1&Dbox1)))
  (if (> l1_sel&Dbox1 0)
    (setq l1_sel&Dbox1 (- l1_sel&Dbox1 1)))
  (JB_PMS:Dbox1:set)
  (JB_PMS:Dbox1:mode)
  )

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

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

 

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


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

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

  (cond
    ((= key "JB_1_p1")
     (JB_PMS:Dbox1:action:p1)     
     )
    ((= key "JB_1_b10");;;Speichern
     (JB_PMS:Dbox1:action:Def:Save)
     (JB_PMS:Dbox1:set)
     )
    ((= key "JB_1_b11");;;Speichern unter
     (JB_PMS:Dbox1:action:b11)
     )
    ((= key "JB_1_b12");;;umbenennen
     (JB_PMS:Dbox1:action:b12)
     )
    ((= key "JB_1_b13");;;löschen
     (JB_PMS:Dbox1:action:b13)
     )
    ((= key "JB_1_b1") ;;;Definition neu
     (setq v_liste(JB_PMS:Dbox2 'T v_liste))
     (JB_PMS:Dbox1:set)
     (JB_PMS:Dbox1:mode)
     )
    ((= key "JB_1_b2") ;;;Definition bearbeiten
     (setq v_liste(JB_PMS:Dbox2 nil v_liste))
     (JB_PMS:Dbox1:set)
     )
    ((= key "JB_1_b3");;;Definition löschen
     (JB_PMS:Dbox1:action:b3)
     )
    ((= key "JB_1_l1")
     (setq l1_sel&Dbox1 (atoi $value))
     (if (= $reason 4)
       (progn
         (setq v_liste(JB_PMS:Dbox2 nil v_liste))
         (JB_PMS:Dbox1:set)
         )
       )
     )
    ((= key "JB_1_to1")
     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 $value "JB_1_to1")))
    ((= key "accept") ;;;Stempel anbringen
     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 key "LastButton"))
     (if(JB_PMS:Dbox1:DefChange-p)
       (if(= 1(JB_PMS:Dbox4 "Die Definitionsliste wurde geändert, vorher speichern?"))
         (progn
           (JB_PMS:Dbox1:action:Def:Save)
           (setq JB_PMS$DCL$_1_po (done_dialog 1))
           )
         )
       (setq JB_PMS$DCL$_1_po (done_dialog 1)))
     )
    ((= key "JB_1_b4") ;;;Stempel entfernen
     (setq Settings&dbox1 (JBf_list:subst:gc Settings&dbox1 key "LastButton"))
     (if(JB_PMS:Dbox1:DefChange-p)
       (if(= 1(JB_PMS:Dbox4 "Die Definitionsliste wurde geändert, vorher speichern?"))
         (progn
           (JB_PMS:Dbox1:action:Def:Save)
           (setq JB_PMS$DCL$_1_po (done_dialog 14))
           )
         )
       (setq JB_PMS$DCL$_1_po (done_dialog 14)))
     )

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

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

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

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

  (JBf_Dcl:AddList:New "JB_1_l1"
    (mapcar '(lambda (X)
               (strcat
                 (cond((>(atof (cadr (assoc 3 X)))0.0)
                       "+")
                      ((=(atof (cadr (assoc 3 X)))0.0)
                       (vl-list->string '(177)))
                      ('T (vl-list->string '(151))))
                 (rtos (abs(atof (cadr (assoc 3 X)))) 2 3)
                 "\t"
                 "b=" (rtos (atof (cadr (assoc 2 X))) 2 3)
                 "\tLayer="
                 (cdr (assoc 2 (cadr (assoc 0 X))))
                 )
               )
      l1&Dbox1))
  (set_tile "JB_1_l1" (itoa l1_sel&Dbox1))
  (set_tile "JB_1_to1" (cdr(assoc "JB_1_to1" Settings&Dbox1))))
                      
;;;DBox1, moden
(defun JB_PMS:Dbox1:mode ( / )
  (if (=(length p1&Dbox1)1)
    (mode_tile "JB_1_b13" 1)
    (mode_tile "JB_1_b13" 0)
    )

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

  (mode_tile (cdr(assoc "LastButton" Settings&Dbox1))2)
  )

;;;DBox2, setten
(defun JB_PMS:Dbox2:set ( / )
  (mapcar '(lambda (X)
             (set_tile (strcat "JB_2_" (car X))
               (cadr X)
               )
             )
    (list
      (list "e1" (cadr (assoc 2 subList&DBox2)))
      (list "e2" (cadr (assoc 3 subList&DBox2)))
      (list "t2" (cdr (assoc "JB_3_t2" Settings&Dbox2)))

      )
    )

  (JBf_Dcl:AddList:New "JB_2_l1"
    LayerListFilter&Dbox2)
  (if l1_sel&Dbox2
    (set_tile "JB_2_l1" (itoa l1_sel&Dbox2))
  )
)


(defun JB_PMS:Dbox2:mode (error / )
  (if error
    (mode_tile (strcat "JB_2_" error)2)
    (mode_tile "JB_2_e2" 2)
    )
  )


;;;DBox 2, getten
(defun JB_PMS:Dbox2:get (/)

  (setq subList&DBox2 (subst (list 2(vl-string-subst "." ","(get_tile "JB_2_e1")))
		       (assoc 2 subList&DBox2)subList&DBox2)
	subList&DBox2 (subst (list 3(vl-string-subst "." ","(get_tile "JB_2_e2")))
		       (assoc 3 subList&DBox2)subList&DBox2)
  )
)
     
;;;Fehlerprüfung
(defun JB_PMS:Dbox2:Check ( /)
  (cond
    ((< (atof (cadr (assoc 2 subList&DBox2))) 0.0)
       (setq error "e1")
       (setq ok -1)
       (alert "Die Breite der Polylinie muss größergleich Null sein.")
    )

  )
  (list ok error)
  )
  
;;;ElementSub-List mit neuem Layer bestücken
(defun JB_PMS:DBox2:ElementSub:NewLayer (LayerName / temp)

  (list
    (list 0 (setq temp (JB_PMS_tblList4v_liste "LAYER" LayerName)))
    (list 1 (JB_PMS_tblList4v_liste "LTYPE" (cdr (assoc 6 temp))))
    (assoc 2 subList&DBox2)
    (assoc 3 subList&DBox2)
  )
)


;;;DBox2, LayerList
(defun JB_PMS:Dbox2:LayerList (/  item RetList )
  (vlax-for item
    (vla-get-layers
      (vla-get-activedocument (vlax-get-acad-object))
    )
    (setq RetList (cons (vla-get-name item) RetList))
  )

  (vl-sort RetList '(lambda (e1 e2)
                            (< e1 e2)
                    )
  )
)

;;;DBox2, Layerlist gefiltert
(defun JB_PMS:Dbox2:LayerList:Filter (Filter /)
  (vl-remove-if '(lambda (X)
                         (not (wcmatch (strcase X)
                                       (strcase Filter)
                              )
                         )
                 )
                LayerList&Dbox2
  )
)

       
;;;DBox2 => Polylinien-Eigenschaften
(defun JB_PMS:Dbox2 (NewFlag v_liste / Settings&Dbox2 subList&DBox2 LayerList&Dbox2 LayerListFilter&Dbox2 l1_sel&Dbox2 DclId ok error A)

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

  
  (setq subList&DBox2 (nth l1_sel&Dbox1 l1&Dbox1))

  ;;;Layer aus ElementListe erstellen, damit diese für Auswahl verfügbar sind
  (JB_PMS:Layer:Entmake subList&DBox2)
  (setq LayerList&Dbox2 (JB_PMS:Dbox2:LayerList))
  (if (or(not(JB_PMS:Dbox2:action:LayerListByFilter (cdr (assoc "JB_3_t2" Settings&Dbox2))))
         (not(member(strcase (cdr (assoc 2 (cadr (assoc 0 subList&DBox2)))))(mapcar 'strcase LayerListFilter&Dbox2))))
    (progn
      (setq Settings&Dbox2 (JBf_list:subst:gc Settings&Dbox2 "*" "JB_3_t2"))
      (setq LayerListFilter&Dbox2 (JB_PMS:Dbox2:LayerList:Filter (cdr (assoc "JB_3_t2" Settings&Dbox2))))
      )
    )
  (setq l1_sel&Dbox2
    (- (length LayerListFilter&Dbox2) (length (member (strcase (cdr (assoc 2 (cadr (assoc 0 subList&DBox2))))) (mapcar 'strcase LayerListFilter&Dbox2))))
  )


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

    (setq DclId (JBf_Dcl:Load_dialog JB_PMS_$DCL$_File "JB_PMS_2" JB_PMS$DCL$_2_po))

    (JB_PMS:Dbox2:set)
    (JB_PMS:Dbox2:mode error)



    (setq error nil)
    (mapcar (function (lambda (A) (action_tile A (strcat "(JB_PMS:Dbox2:action \"" A "\")"))))
            '(
               "JB_2_l1" "JB_2_b1"
               "accept" "cancel"
             )
    )

    (setq ok (start_dialog))
    (unload_dialog DclId)


    (if (= ok 1)
      (setq ok (JB_PMS:Dbox2:Check)
	    error (cadr ok)
	    ok (car ok)))


    (cond
      ((= ok 1)
       (setq RetList(if NewFlag
		      (append (list (cons "New" subList&DBox2))(mapcar '(lambda(X)
								    (cons "Alt" X))l1&Dbox1))
		      (JBf_list:nth:change (mapcar '(lambda(X)
						      (cons "Alt" X))l1&Dbox1)
			(cons "New" subList&DBox2) l1_sel&Dbox1))
	     RetList (vl-sort RetList (function(lambda(e1 e2)(< (atof(cadr(assoc 3 (cdr e1))))(atof(cadr(assoc 3 (cdr e2))))))))
	     l1_sel&Dbox1 (- (length RetList)(length (member "New" (mapcar 'car RetList))))
	     l1&Dbox1 (mapcar 'cdr RetList)
             
	     )
       (setq v_liste (JB_PMS:v_liste:DboxSettings:put "Dbox2" Settings&dbox2 v_liste))

      )

    )
  )
   v_liste
  )

;;;Prüfen, ob ein Filter eine Layerliste zurückgibt
(defun JB_PMS:Dbox2:action:LayerListByFilter (Filter / LayerListFilter)
  (if(setq LayerListFilter(JB_PMS:Dbox2:LayerList:Filter Filter))
    (setq LayerListFilter&Dbox2 LayerListFilter)
    )
  )
    
;;;Action (Variable global in Aufrufender Funktion)
(defun JB_PMS:Dbox2:action (key / Filter)

  (cond
    ((= key "JB_2_l1")   ;;;Button Elementlayer bearbeiten
     (JB_PMS:Dbox2:get)
     (setq l1_sel&Dbox2 (atoi $value))
     (setq subList&DBox2 (JB_PMS:DBox2:ElementSub:NewLayer (nth l1_sel&Dbox2 LayerListFilter&Dbox2)))
     )

    ((= key "JB_2_b1")   ;;;neuer FilterWert
     (JB_PMS:Dbox2:get)
     
     (if (and (setq Filter (JB_PMS:DBox3 "Filter" (cdr (assoc "JB_3_t2" Settings&Dbox2))))
              (or (/= Filter "")
                  (setq Filter "*")
                  )
              (or
                (and
                  (JB_PMS:Dbox2:action:LayerListByFilter Filter)
                  (setq Settings&Dbox2 (JBf_list:subst:gc Settings&Dbox2 Filter "JB_3_t2"))
                  (setq l1_sel&Dbox2 0))
                (alert "Der Filter entspricht keinem Layer in der Zeichnung.")))
       (JB_PMS:Dbox2:set)
       )
    )
    

    ((= key "accept");;;Auswahl mit OK abschließen
     (JB_PMS:Dbox2:get)
     (setq JB_PMS$DCL$_2_po (done_dialog 1))
    )
    ((= key "cancel")    ;;;Abbrechen
     (setq JB_PMS$DCL$_2_po (done_dialog 99))
    )

  )
)

;;;DBox3, Textwert zurückgeben
(defun JB_PMS:Dbox3 (Header wert / ok DclId)

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

    (setq DclId (JBf_Dcl:Load_dialog JB_PMS_$DCL$_File "JB_PMS_3" JB_PMS$DCL$_3_po))

    (set_tile "JB_3" header)
    (set_tile "JB_3_e1" wert)
    (mode_tile "JB_3_e1" 2)


    (mapcar (function (lambda (A) (action_tile A (strcat "(JB_PMS:Dbox3:action \"" A "\")"))))
            '(

               "accept" "cancel"
             )
    )

    (setq ok (start_dialog))
    (unload_dialog DclId)



  )
       wert
)

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

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

  )
)



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

         
;;;DCL-schreiben
(defun JB_PMS:dcl:Write ( / file)  
  (if (and (setq JB_PMS_$DCL$_File (vl-filename-mktemp (strcat "PMS.dcl")))
           (setq file (open JB_PMS_$DCL$_File "w"))
      )
    (progn
      (mapcar '(lambda (A)
                       (write-line A file)
               )
              (mapcar '(lambda (A)
                               (strcat "\n" A)
                       )
              (list
                "//Hauptdialog"
                "JB_PMS_1: dialog {label= \"Multilinienstempel für Polylinien\";	 "
                ":boxed_column {label = \"Multilinienstempel-Definitionen\";"
                ":popup_list {key = \"JB_1_p1\"; label = \"Definition\";}"
                ":row {"
                ":button {key = \"JB_1_b10\"; label = \"Spei&chern\";}"
                ":button {key = \"JB_1_b11\"; label = \"&Speichern unter...\";}"
                ":button {key = \"JB_1_b12\"; label = \"U&mbenennen...\";}"
                ":button {key = \"JB_1_b13\"; label = \"Lösc&hen\";}}"
                ":list_box {key = \"JB_1_l1\"; label = \"Eigenschaften\";width=60; tabs = \"8 12\";}"
                ":row{"
                ":button{key = \"JB_1_b1\"; label = \"&Neu...\";}"
                ":button{key = \"JB_1_b2\"; label = \"&Bearbeiten...\";}"
                ":button{key = \"JB_1_b3\"; label = \"&Löschen\";}"
                "}"
                "}"
                ":boxed_column {label = \"Aktionen für Multilinienstempel bei Polylinien\";"
                ":toggle {key = \"JB_1_to1\"; label = \"Polylinien picken (nur beim neu anbringen)\";}"
                ":row {"
                ":button {key = \"accept\"; label = \"neu &anbringen\";}"
                ":button {key = \"JB_1_b4\"; label = \"&entfernen\";}"
                ":button {key = \"JB_1_b5\"; label = \"&wiederherstellen\";}"
                "}"
                "}"
                ":row{fixed_width = true;alignment = centered;"
                ":retirement_button {label = \"&Ende\"; key= \"cancel\"; fixed_width = true;is_cancel=true;}"
                "}"
                "}"
                "JB_PMS_2: dialog {label= \"Definitions-Eigenschaften\";"
                ":boxed_column {label = \"zuweisen\";"
                ":list_box {key = \"JB_2_l1\"; label = \"Layer\"; width = 60; height = 20;}"
                ":row{"
                ":button {key = \"JB_2_b1\"; label = \"&Filter...\"; fixed_width = true;}"
                ":text {key = \"JB_2_t2\"; label = \"*\";width= 50;}"
                "}"
                ":spacer {height = 1;}"
                ":edit_box {key = \"JB_2_e1\"; label = \"Breite\"; edit_width = 12; allow_accept=true;}"
                ":edit_box {key = \"JB_2_e2\"; label = \"Abstand\"; edit_width = 12; allow_accept=true;}"
                "}"
                "ok_cancel;}"
                "JB_PMS_3: dialog {key = \"JB_3\";"
                ":boxed_column {label = \"bitte eingeben:\";"
                ":edit_box {key = \"JB_3_e1\"; allow_accept=true;}"
                "}"
                "ok_cancel;}"
                "JB_PMS_4: dialog {label = \"Frage: Ja oder Nein\";"
                ":text {value = \"Hier kommt die zu bejahende oder beneinende Frage hin.\"; key =\"JB_jn\"; width = 100;}"
                ": row {fixed_width = true;alignment = centered;"
                ": retirement_button {label= \" Ja \"; key   = \"JB_ja\"; is_default  = true; }"
                ": spacer { width = 2; }"
                ": retirement_button {label = \"Nein\"; key = \"JB_nein\"; is_cancel= true;}}}"



               )
              )
      )
      (close file)
      JB_PMS_$DCL$_File
    )
  )
)


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

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

;;;Initialisierungsfunktion
(defun JBf_init (InitVaris / )
  (setq	JB_Error *error*
        *error* JBf_Error)
  (vl-load-com)
  ;;;Systemvariablen aktuelle Einstellungen für ReInit speichern
  (setq JBf$ReInit$Varis
         (mapcar '(lambda(A)
                    (list (car A)(getvar (car A))))InitVaris))
  ;;;Vorgabeeistellungen für Systemvariablen
  (mapcar '(lambda(A)
             (if (cadr A)
               (setvar (car A)(cadr A))))InitVaris)
  )

;;;Reinitialisierung
(defun JBf_Reinit ( / n)
  ;;;Systemvariablen ReInitialisieren
  (mapcar '(lambda(A)
             (setvar (car A)(cadr A)))JBf$ReInit$Varis)
  (setq JBf$ReInit$Varis nil)
  (princ)
)

;;;--------------------------------------------------------------------------------------------------------
;;;allgemeine Funktionen => Strings								   	   
;;;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

;;;benutzerspezifischer Pfad zum Speichern von Programmeinstellungen auf dem Benutzer von Windows
;;;Übergeben wird der relative Pfad, der hinter den Windows-Pfad angehängt wird. Wenn die Verzeichnisse nicht vorhanden sind werden sie erstellt.
(defun JBf_String:Userpfad:WinUser (UserPfad / )
  
  (setq UserList (JBf_String:Delimiter->List UserPfad "\\"))
  (setq Pfad (strcat "c:\\Users\\"(getvar "LOGINNAME")"\\"))
        

  ;;;wenn UserPfad noch nicht vorhanden, dann erstellen
  (mapcar '(lambda(A)
             (setq Pfad (strcat Pfad A "\\"))
             (if (not (JBf_String:FilePath? Pfad))
               (vl-mkdir Pfad)))
    UserList)
  Pfad
  )
;;;String anhand Trennzeichen in Liste zurückgeben
(defun JBf_String:Delimiter->List (Str Delim / StrList)
  (setq Str (vl-string-left-trim Delim Str)
	Str (vl-string-right-trim Delim Str))
  (if (vl-string-search Delim Str)
    (progn
      (while (vl-string-search Delim Str)
        (setq StrList (cons (substr Str 1 (vl-string-search Delim Str))StrList)
	      Str (vl-string-left-trim Delim(substr Str(+(vl-string-search Delim Str)(+ (strlen Delim)1))))))
      (if (/= Str "")
        (setq StrList (cons Str StrList))))
    (setq StrList (cons Str StrList)))
  (reverse StrList))

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

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

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

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

;;;alle Objekte eins Auswahlsatzes löschen (ohne Command) ;alle Objekte eins Auswahlsatzes schieben => Koordinaten müssen in Welt übergeben werden
(defun JBf_aws:Vla-DeleteRefresh (aws / n A)
  (if aws
    (progn
      (setq n 0)
      (repeat (sslength aws)
        (if (and (ssname aws n)
              (entget (ssname aws n)))
          (progn
            (setq A (vlax-ename->vla-object (ssname aws n)))
            (vla-move A(vlax-3D-point '(0.0 0.0))(vlax-3D-point (list 0.0 (*(getvar "VIEWSIZE")10.0))))
            (vlax-invoke A 'Update)
            (vlax-invoke A 'Delete)))
        
        (setq n (+ n 1))))))


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

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

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

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


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

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

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

    (if TruthPathSet
      (JBf_AcadSystem:TrustedPaths:Delete (strcat (car (fnsplitl PathFile)) "..."))
    )


    (list error RetVal)
  )
;;;Iteratives lustiges Listenschreiben
  (defun JBf_SIC:sichern:prin1 (A FileStream / B)

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

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

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

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

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

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

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

;;;DCL-Liste komplett neu füllen
(defun JBf_Dcl:AddList:New (key liste / )
  (start_list key 3)
  (mapcar 'add_list liste)
  (end_list)
  )

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

;;;Koordinatenliste umformen
(defun JBf_VlaObjects:GetKoord->List (n z liste / LISTE1 I)
  (setq i (* n -1))
  (repeat (/ (length liste) n)
    (setq i (+ i n))
    (setq liste1 (cons (list (nth i liste) (nth (+ i 1) liste) (if z z (nth (+ i 2) liste))) liste1))
  )
  (reverse liste1)
  )

;;;Koordinaten aus vla-Objekten abfragen
(defun JBf_VlaObjects:GetKoord (vla-obj /)
  (cond
    ((member (vla-get-ObjectName vla-obj) '( "AcDbPolyline" "AcDbLwPolyline"))
             (JBf_VlaObjects:GetKoord->List 2 (vla-get-Elevation vla-obj) (vlax-get vla-obj 'Coordinates))
    )

    ((= (vla-get-ObjectName vla-obj) "AcDb2dPolyline")
        (JBf_VlaObjects:GetKoord->List 3 (vla-get-Elevation vla-obj) (vlax-get vla-obj 'Coordinates))
    )

    ((= (vla-get-ObjectName vla-obj) "AcDb3dPolyline")
        (JBf_VlaObjects:GetKoord->List 3 nil (vlax-get vla-obj 'Coordinates))
    )


    ((= (vla-get-ObjectName vla-obj) "AcDbArc")
        (list
          (vlax-get vla-obj 'StartPoint)
          (polar (vlax-get vla-obj 'Center)
                 (angle (vlax-get vla-obj 'Center)
                        (polar (vlax-get vla-obj 'StartPoint) (angle (vlax-get vla-obj 'StartPoint) (vlax-get vla-obj 'EndPoint))
                               (/ (distance (vlax-get vla-obj 'StartPoint) (vlax-get vla-obj 'EndPoint)) 2.0)
                        )
                 )
                 (vla-get-Radius vla-obj)
          )
              (vlax-get vla-obj 'EndPoint)
        )
    )

    ((= (vla-get-ObjectName vla-obj) "AcDbLine")
        (list
          (vlax-get vla-obj 'StartPoint)
          (vlax-get vla-obj 'EndPoint)
        )
    )
  )
)

;;;XDaten mit VLA-Funktionen lesen, weil z.B. in DBX-Objekten dann auch verläßlich Daten zurück gegeben werden

(defun JBf_list_xdaten_read:Vla (art vla-obj gc_nr / DATACODE N RETLIST VALUE VARDATATYPES VARDATAVALUES VARVALUE)

  (vla-GetXData vla-obj art 'VarDataTypes 'VarDataValues)
  (if VarDataTypes
      (progn
        ;; Get the dimension of the safearray
        (setq n (vlax-safearray-get-l-bound VarDataTypes 1))
        
         (while (<= n (vlax-safearray-get-u-bound VarDataTypes 1))
           (setq dataCode (vlax-safearray-get-element VarDataTypes n))
           (setq VarValue (vlax-safearray-get-element VarDataValues n))
           
            ;; VarValue contains the variant, but we need the Lisp value of it

           (if (and (> dataCode 1009) (< dataCode 1040))
             ;; Test to see if it's a point Variant
             (setq Value (vlax-safearray->list (vlax-variant-value VarValue)))
             (setq Value (vlax-variant-value VarValue))
            )
            ;; Create the list
            (setq RetList (append RetList (list (cons dataCode Value))))
            (setq n (+ n 1))
         ) ;_ end of while
      ) ;_ end of progn
    )
  (setq RetList(vl-remove-if '(lambda(X)(=(car X)1001))RetList))
  (if gc_nr
    (cdr(assoc gc_nr RetList))
    RetList))

;;;XDaten mit VLA-Funktionen anhängen, weil z.B. in DBX-Objekten dann auch verläßlich Daten zurück gegeben werden
(defun JBf_list_xdaten_append:Vla (art vla-obj liste / ARRAYTYPES ARRAYVALUES CODES N VALUES)
  ;; Register an application name
  (regapp art)

  ;; Attach some xdatas:
  ;; 1001: application name  ;; 1000: string ;; 1010: 3D point ;; 1040: real ; 1070: 16bit integer
  (setq codes (cons 1001 (mapcar 'car liste))
        values (cons art (mapcar 'cdr liste)))

  ;; Create the Safe and Variant Arrays needed for vla-SetXData
  (setq ArrayTypes
         (vlax-make-safearray
           vlax-vbInteger
           (cons 0 (-(length codes)1))
           )
        ArrayValues
         (vlax-make-safearray
           vlax-vbVariant
           (cons 0 (-(length codes)1))
           ))
  ;;; Fill the Arrays; simple list works
  (vlax-safearray-fill ArrayTypes codes)

  ; A more complex list needs to be constructed one element at a time:
  (setq n 0)
  (while (< n (length codes))
    (if (=(type (nth n values)) 'LIST)
      (vlax-safearray-put-element
        ArrayValues
        n
        (vlax-3d-point (nth n values)))
      (vlax-safearray-put-element ArrayValues n (nth n values)))
    (setq n (+ n 1)))

  (vla-SetXData vla-obj ArrayTypes ArrayValues)
  )




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

(princ (strcat
          "\n|++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++|"
          "\n|Multilinienstempel für Polylinien.                          |"
          "\n|------------------------------------------------------------|"
          "\n|erstellt durch Bosse-engineering - www.bosse-engineering.com|"
          "\n|------------------------------------------------------------|"
          "\n|Befehlszeilenaufruf: PMS                                    |"
          "\n|++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++|"
          )
       )
(princ)

