;;;       2.5.5 Ordner bemassen                                  qpbem1

;;; 
;;;   QPBEM1.lsp
;;;   (C) Copyright 1997 by Ing. Michael Kratschmer
;;;  
;;;   PROGRAMMBESCHREIBUNG
;;;   Das Programm "QPBEM1" dient der automatischen Ordner-Bemassung fuer
;;;   das Kunstkoerper- oder Bestandshoehenband in STRAB-Profilen. 
;;;
;;;   Es werden in das STRAB-Profil-Kotenband der Abstand von der Profil-
;;;   achse und die Hoehe des Punktes angeschrieben (2 bzw. 3 Nachkomma-
;;;   stellen).
;;;   Voraussetzungen:
;;;   1)  Profil muss in richtigen "World"-Koordinaten sitzen (VE+Hoehe)
;;;   2)  Ordner von allen Punkten, die man Bemassen will, bis auf die
;;;       Vergleichsebene ziehen
;;;   3)  Abfrage ob "Bestand" oder "Kunstkoerper" zu bemaßen ist
;;;   4)  Untere Maszlinie anklicken - Ordner anklicken (egal wo)
;;;   5)  Abstand und Hoehe wird eingetragen (Layer NEUKOTE bei Kunst-
;;;       koerper und Layer BESTKOTE bei Bestand)
;;;
;;;   by Ing. Michael Kratschmer
;;;   
;;;   REVISIONS
;;;   1.0    06. April 1997   --  imk
;;; 
;;;--------------------------------------------------------------------------;
;;;   V A R I A B L E N
;;;   qpbem1_ver   Versionsnummer des Programms "QPBEM1"
;;;   qpbem1_er    Fehlerbehandlungsvariable
;;;   qpbem1_oe    Old Error - alter Fehlercode
;;;   qpbem1_oc    ACAD-Variableninhalt "CMDECHO"
;;;   qpbem1_uml   Programmteil: Untere Maszlinie bestimmen
;;;   qpbem1_orl   Programmteil: Ordnerlinie bestimmen
;;;   qpbem1_bes   Programmteil: Kotenbandbeschriftung
;;;   uml          Untere Maszlinie (Unterkante Bemassung)
;;;   e_uml        Gewaehltes Element als untere Maszlinie
;;;   typ_uml      Type  des gewaehlten Elements ... Soll = LINE
;;;   lay_uml      Layer des gewaehlten Elements ... Soll = 2
;;;   pkt10_uml    Anfangspunkt untere Maszlinie
;;;   y10_uml      y-Koordinate des Anfangspunktes der unteren Maszlinie
;;;   pkt11_uml    Endpunkt untere Maszlinie
;;;   y11_uml      y-Koordinate der Endpunktes der unteren Maszlinie
;;;   orl          Ordnerlinie (Linie zur Bemassung)
;;;   e_orl        Gewaehltes Element als Ordnerlinie
;;;   typ_orl      Type  des gewaehlten Elements ... Soll = LINE
;;;   lay_orl      Layer des gewaehlten Elements ... Soll = ORDNER
;;;   pkt10_orl    Anfangspunkt Ordnerlinie
;;;   x10_orl      x-Koordinate des Anfangspunktes der Ordnerlinie
;;;   y10_orl      y-Koordinate des Anfangspunktes der Ordnerlinie
;;;   pkt11_orl    Endpunkt Ordnerlinie
;;;   x11_orl      x-Koordinate der Endpunktes der Ordnerlinie
;;;   y11_orl      y-Koordinate der Endpunktes der Ordnerlinie
;;;   pkt_a        Abstand Bemassungspunkt von Profilachse (absolut)
;;;   pkt_h        Hoehe Bemassungspunkt (absolut)
;;;   pt1, pt2     Anfangs- und Endpunkt von Zeichenlinien
;;;   ptins        Einsetzpunkt von Texten
;;;   pkt_at       Abstand Bemassungspunkt (als Textstring)
;;;   pkt_ht       Hoehe Bemassungspunkt (als Textstring)
;;;   leerz        CHR32 = Space = Leerzeichen
;;;   alt_lay      Ursprungslayer
;;;   opt          Auswahl Kunstkoerper oder Bestand
;;;   ------------------------------------------------------------------------  
(defun qpbem1 (Art	  /	     qpbem1_ver	qpbem1_er  qpbem1_oe
	       qpbem1_oc  opt	     uml	e_uml	   typ_uml
	       lay_uml	  pkt10_uml  y10_uml	pkt11_uml  y11_uml
	       orl	  e_orl	     typ_orl	lay_orl	   pkt10_orl
	       x10_orl	  y10_orl    pkt11_orl	x11_orl	   y11_orl
	       pkt_a	  pkt_at     pkt_h	pkt_ht	   pt1
	       pt2	  ptins	     leerz	alt_lay
	      )
;;;   ------------------------------------------------------------------------  
  (setq qpbem1_ver "2.1")		; Variable aendern, wenn Programmversion
					; geaendert wird
  ;;
  ;; Interne Fehlerbehandlung lokal definiert
  ;;
  (defun qpbem1_er (msg)		; Wenn ein Fehler (z.B. CTRL-C) erfolgt
					; waehrend dieser Befehl aktiv ist .....
    (if	(/= msg "Function cancelled")
      (if (= msg "quit / exit abort")
	(princ)
	(princ (strcat "\nError: " msg))
      )
    )
    (if	qpbem1_oe			; Wenn eine aelterer Fehlerroutine
      (setq *error* qpbem1_oe)		; existiert, wird sie zurückgesetzt
    )
    (if	temp
      (redraw temp 1)
    )
    (if	qpbem1_oc
      (setvar "cmdecho" qpbem1_oc)
    )					; command Anzeige rücksetzen
    (princ)
  )
  ;;
  ;; Beginn Hauptprogramm
  ;;
  (if *error*				; Setzen unserer neuen Fehlerroutine
    (setq qpbem1_oe *error*
	  *error* qpbem1_er
    )
    (setq *error* qpbem1_er)
  )

  (setq qpbem1_oc (getvar "cmdecho"))
  (setvar "cmdecho" 0)

  (princ
    (strcat "\nQUERPROFIL-Ordnerbemassung, Version "
	    qpbem1_ver
	    ", (c) 1997 by imk , (c) 1999 by Stefan Prochazka "
    )
  )

;;; Überprüfen, ob der Stil duenn_sto existiuert
  (if (= (tblobjname "style" "duenn_sto") nil)
    (progn
      (princ "\nEs ist kein Stil Duenn_Sto verfügbar")
      (princ "\nDie Funktion wird daher abgebrochen")
      (exit)
    )
  )					; ende if
  (setq StiltoUse "duenn_sto")

  ;; Überprüfen ob fixe Höhe
  (if (/= 0
	  (cdr (assoc 40 (entget (tblobjname "style" StilToUse))))
      )
    (progn
      (princ "\nVorsicht ! Der gewählte Stil hat eine fixe Höhe!")

      (initget 1 "Ja Nein")
      (if (= "Nein"
	     (getkword "\nSoll fortgefahren werden: <J>a/<N>ein: ")
	  )
	(exit)
      )					; ende if
    )

  )					; end if



  ;; Abfrage ob Kunstkoerper oder Bestandsgelaende beschriftet werden soll
  (qpbem1_abf)


  ;; Untere Maszlinie bestimmen
  (while (or (/= typ_uml "LINE")
	     (/= (rtos y10_uml 1 4) (rtos y11_uml 1 4))
	 )
    (qpbem1_uml)
  )
  ;; Ordner bestimmen
  ;; abhängig von art von qpbem1(a)
  ;; "Normal" so wie bisher
  ;; "erweitert" zeichnet zusätzlich den Ordner ein

  ;; Abfrage nach Vergleichsebene nur bei Modus "erweitert"
  (setq typ_VE nil)
  (if (= Art "erweitert")
    (while (or (/= typ_VE "LINE")
	       (/= (rtos y10_VE 1 4) (rtos y11_VE 1 4))
	   )
      (qpbem1_VE)
    )
  )

  (setq orl "")
  (while (= orl "")
    (while (or (/= typ_orl "LINE")
	       (/= (rtos x10_orl 1 4) (rtos x11_orl 1 4))
	   )
      (if (= Art "normal")
	(qpbem1_orl)
	(qpbem1_orl_a)
      )
    )
    ;; Kotenbandbeschriftung
    (qpbem1_bes)
    (setq orl "")
    (setq typ_orl "")
  )

  (if qpbem1_oe
    (setq *error* qpbem1_oe)
  )					; Alter Fehlerfunktion zurueck-
					; setzen bei Fehler
  (if qpbem1_oc
    (setvar "cmdecho" qpbem1_oc)
  )					; Reset Befehlsanzeige
  (princ)				; ACAD-Variable cmdecho
)
;;; Hauptprogramm-Ende
;;; -------------------------------------------------------------------------
;;; Programmteil :   Abfrage Kunstkoerper oder Bestandsgelaende
(defun qpbem1_abf ()
  (princ "\nWas soll bemaßt werden - ")
  (initget 1 "Bestand Kunstkörper")
  (setq opt (getkword "\ <B>estand/<K>unstkörper:  "))
)
;;; -------------------------------------------------------------------------
;;; Programmteil :   Untere Maßlinie bestimmen
(defun qpbem1_uml ()
  (setq
    uml	(entsel
	  "\n1.Schritt:  Zeige die untere Bemassungslinie (unter VE)"
	)
  )
  (setq e_uml (entget (car uml)))
  (setq typ_uml (cdr (assoc 0 e_uml)))
  (setq lay_uml (cdr (assoc 8 e_uml)))
  (setq pkt10_uml (cdr (assoc 10 e_uml)))
  (setq y10_uml (cadr pkt10_uml))
  (setq pkt11_uml (cdr (assoc 11 e_uml)))
  (setq y11_uml (cadr pkt11_uml))
  (if (= typ_uml "LINE")
    (if	(= (rtos y10_uml 1 4) (rtos y11_uml 1 4))
;;;; Vergleich der Koordinaten auf vier Nachkommastellen genau
;;;   (if (/= lay_uml "2")
      ;;	(progn
					;	  (alert
					;	    "Hinweis - Maßlinie liegt nicht auf üblichem Layer (2) !"
					;	  )
					;	)
					;     )
      (princ)				; ja 
      (alert "Fehler - Linie nicht horizontal oder BKS falsch !") ;nein
    )
    (alert "Fehler - Gewähltes Objekt ist keine Linie !")
  )
)
;;; -------------------------------------------------------------------------
;;; Programmteil :   Vergleichsebene bestimmen
(defun qpbem1_VE ()
  (setq
    VE (entsel
	 "\n2.Schritt:  Zeige die Vergleichsebene (VE)"
       )
  )
  (setq e_VE (entget (car VE)))
  (setq typ_VE (cdr (assoc 0 e_VE)))
  (setq lay_VE (cdr (assoc 8 e_VE)))
  (setq pkt10_VE (cdr (assoc 10 e_VE)))
  (setq y10_VE (cadr pkt10_VE))
  (setq pkt11_VE (cdr (assoc 11 e_VE)))
  (setq y11_VE (cadr pkt11_VE))
  (if (= typ_VE "LINE")
    (if	(= (rtos y10_VE 1 4) (rtos y11_VE 1 4))
;;;; Vergleich der Koordinaten auf vier Nachkommastellen genau
      (progn)
      (alert "Fehler - Linie nicht horizontal oder BKS falsch !")
    )
    (alert "Fehler - Gewähltes Objekt ist keine Linie !")
  )
)
;;; -------------------------------------------------------------------------
;;; Programmteil:   Ordner bestimmen
(defun qpbem1_orl ()
  (setq
    orl	(entsel
	  "\n2.Schritt:  Zeige den Ordner der beschriftet werden soll"
	)
  )
  (if (null orl)
    (progn
      (princ "\Nichts ausgewählt - somit Programm beendet = ")
      (exit)
    )
  )
  (setq e_orl (entget (car orl)))
  (setq typ_orl (cdr (assoc 0 e_orl)))
  (setq lay_orl (cdr (assoc 8 e_orl)))
  (setq pkt10_orl (cdr (assoc 10 e_orl)))
  (setq y10_orl (cadr pkt10_orl))
  (setq x10_orl (car pkt10_orl))
  (setq pkt11_orl (cdr (assoc 11 e_orl)))
  (setq y11_orl (cadr pkt11_orl))
  (setq x11_orl (car pkt11_orl))
  (if (= typ_orl "LINE")
					;    (if	(= (rtos y10_orl 1 4) (rtos y11_orl 1 4))
;;;; Vergleich der Koordinaten auf vier Nachkommastellen genau	
					;      (if (/= lay_orl "ORDNER")
					;	(progn
					;	  (alert
					;	    "Hinweis - Ordnerlinie liegt nicht auf üblichem Layer (ORDNER) !"
					;	  )
					;	)
					;      )
					;     (princ)  ;ja
					;      (alert "Fehler - Linie nicht senkrecht oder BKS falsch !") ;nein
					;    )
    (princ)
    (alert "Fehler - Gewähltes Objekt ist keine Linie !")
  )
)
;;; -------------------------------------------------------------------------
;;; Programmteil:   Ordner einzeichnen und bestimmen
(defun qpbem1_orl_a ()
  (setq
    orl_a (getpoint
	    "\n3.Schritt:  Zeige den Geländepunkt für den Ordner"
	  )
  )
  (if (= nil orl_a)
    (progn
      (princ "\Nichts ausgewählt - somit Programm beendet = ")
      (exit)
    )
  )
  (setq ptord1 (list (car orl_a) (car (cdr orl_a)) 0))
  (setq ptord2 (list (car orl_a) y10_VE 0))

  (setq	e_orl (entmake

		(list
		  (cons 0 "LINE")
		  (cons 8 "Ordner")
		  (cons 67 0)
		  (cons 10 ptord1)
		  (cons 11 ptord2)
		)
	      )
  )

  (setq typ_orl (cdr (assoc 0 e_orl)))
  (setq lay_orl (cdr (assoc 8 e_orl)))
  (setq pkt10_orl (cdr (assoc 10 e_orl)))
  (setq y10_orl (cadr pkt10_orl))
  (setq x10_orl (car pkt10_orl))
  (setq pkt11_orl (cdr (assoc 11 e_orl)))
  (setq y11_orl (cadr pkt11_orl))
  (setq x11_orl (car pkt11_orl))


)



;;; -------------------------------------------------------------------------   
;;; Programmteil:   Abstand und Hoehe in Kotenband schreiben
(defun qpbem1_bes ()
  (setq DIMZINWERT (getvar "DIMZIN"))
  (setvar "DIMZIN" 0)
  (if (> y11_orl y10_orl)
    (setq pkt_h y11_orl)
    (setq pkt_h y10_orl)
  )
  (setq pkt_a x11_orl)
  (setq alt_lay (getvar "clayer"))
  (if (= opt "Kunstkörper")
    (if	(= (ssget "x" (list (cons 8 "NEUKOTE"))) nil)
      (progn
	(command "_layer" "_m" "NEUKOTE" "_c" "2" "" "")
	(setq laynam "NEUKOTE")
      )
      (progn
	(command "_layer" "_s" "NEUKOTE" "")
	(setq laynam "NEUKOTE")
      )
    )
    (if	(= (ssget "x" (list (cons 8 "BESTKOTE"))) nil)
      (progn
	(command "_layer" "_m" "BESTKOTE" "_c" "11" "" "")
	(setq laynam "BESTKOTE")
      )
      (progn
	(command "_layer" "_s" "BESTKOTE" "")
	(setq laynam "BESTKOTE")
      )
    )
  )
  (setq pt1 (list pkt_a y10_uml 0))
  (setq pt2 (list pkt_a (+ y10_uml 0.1) 0))
;;;(command "_line" pt1 pt2 "")

  (setq ptins (list (+ pkt_a 0.0875) (+ y10_uml 0.20) 0))
  (if (= opt "Kunstkörper")
    (setq pkt_ht (rtos pkt_h 2 3))
    (setq pkt_ht (rtos pkt_h 2 2))
  )
;;;(command "_text" "_s" "ISOCP" ptins "0.175"  pkt_ht "")
  ;; als entmake (mit Überprüfung)






  (if (= (entmake

	   (list
	     (cons 0 "Text")
	     (cons 1 pkt_ht)
	     (cons 7 StilToUse)		; Stil
	     (cons 10 ptins)
	     (cons 40 0.175)
	     (cons 50 (/ pi 2))
	     (cons 67 0)
	   )

	 )
	 nil
      )
    (progn
      (Alert
	"Die Eintragung des Wertes ist fehlgeschlagen. \n Wahrscheinlich ist die Schriftart (ISOCP) nicht definiert."
      )
;;; bereits erzeugte Linien löschen

      (exit)
    )					; ende Progn

  )
  (entmake

    (list
      (cons 0 "LINE")
      (cons 8 laynam)
      (cons 67 0)
      (cons 10 pt1)
      (cons 11 pt2)
    )
  )

  (setq pt1 (list pkt_a (+ y10_uml 1.0) 0))
  (setq pt2 (list pkt_a (+ y10_uml 1.2) 0))
  ;;(command "_line" pt1 pt2 "")
  (entmake

    (list
      (cons 0 "LINE")
      (cons 8 laynam)
      (cons 67 0)


      (cons 10 pt1)
      (cons 11 pt2)


    )
  )

  (setq pt1 (list pkt_a (+ y10_uml 2.1) 0))
  (setq pt2 (list pkt_a (+ y10_uml 2.2) 0))
  ;;(command "_line" pt1 pt2 "")
  (entmake

    (list
      (cons 0 "LINE")
      (cons 8 laynam)
      (cons 67 0)


      (cons 10 pt1)
      (cons 11 pt2)


    )
  )



  (setq ptins (list (+ pkt_a 0.0875) (+ y10_uml 1.30) 0))
  (if (= opt "Kunstkörper")
    (setq pkt_at (rtos (abs pkt_a) 2 3))
    (setq pkt_at (rtos (abs pkt_a) 2 2))
  )
  (setq leerz (chr 32))
  (if (> (abs pkt_a) 10)
    (setq pkt_at (strcat "" pkt_at))
    (setq pkt_at (strcat leerz pkt_at))
  )
  ;;(command "_text" "_s" "ISOCP" ptins "0.175" pkt_at "")
  ;; als entmake
  (if (= (entmake

	   (list
	     (cons 0 "Text")
	     (cons 1 pkt_at)
	     (cons 7 StilToUse)		; Stil
	     (cons 10 ptins)
	     (cons 40 0.175)
	     (cons 50 (/ pi 2.0))
	     (cons 67 0)
	   )

	 )
	 nil
      )
    (Alert
      "Die Eintragung des Wertes ist fehlgeschlagen. \n Wahrscheinlich ist die Schriftart (ISOCP) nicht definiert."
    )
  )
  (setvar "clayer" alt_lay)
  (setvar "DIMZIN" DIMZINWERT)
)
;;; -------------------------------------------------------------------------
;;; Programmuebergabe ACAD
(defun C:qpbem1 () (qpbem1 "normal"))
;;; (princ "\n\t c:QUERPROFIL-Ordnerbemassung 1  ->  Start mit QPBEM1.  ")
(princ)


					; Ende von qpbem1

;;;       2.5.6 Ordner einzeichnen und bemassen			 qpbem1a

;;; Programmuebergabe ACAD
(defun C:qpbem1a () (qpbem1 "erweitert"))
					; Ordner werden gezeichnet und bemasst