;|; --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --=={©ABBS©}==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- ;|; ;|; Copyright© 2023 Archäologische Bodenforschung Basel-Stadt. ;|; ;|; Alle Rechte am Code und der Zusammenstellung sind vorbehalten. Die Nutzung der Software geschieht auf eigenes Risiko. ;|; ;|; Die Archäologische Bodenforschung Basel-Stadt schliesst eine Haftung für Probleme, Fehler und Schäden, die bei der Nutzung der ;|; ;|; Software an Hardware, Software oder damit erstellten Softwareprodukten und -dateien, aus. Es besteht kein Anspruch auf Support. ;|; ;|; Eine Weitergabe der Software ist nicht gestattet. Interessenten können sich bei Interesse melden bei: Fabian Bubendorf, fabian.bubendorf@bs.ch ;|; ;|; --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --=={©ABBS©}==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- --==©==-- ;|; ;;; --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --=={ ABBS }==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- ;;; ;|; Böschungslinien generieren ;|; ;;; --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --=={ ABBS }==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- ;;; ;;; Befehl: L-Boeschung ;;; ;;; Zweck: Zum automatischen Erstellen von Böschungslinien zwischen zwei Linien nach Dynamischem- oder Fixem-Wert ;;; ;;; Funktionen: (GETLINES . 0) ;;; ;;; |->(SELLINES . 0) ;;; ;;; |->(MAKELINE . 2) ;;; ;;; (CHECKDIR . 0) ;;; ;;; (BOESCHLST . 1) ;;; ;;; |->(ISONCU? . 2) ;;; ;;; |->(ISOVERCU? . 2) ;;; ;;; (LM:POPUP . 3) ;;; ;;; (WRITEDCL . 0) ;;; ;;; (GETVECLST . 4) ;;; ;;; |->(GETCOOLST . 1) ;;; ;;; (DIALOG . 2) ;;; ;;; |->(DRAWIMG . 2) ;;; ;;; (CHECKLAY . 1) ;;; ;;; (MAKEBOESCH . 1) ;;; ;;; Dialog: Ja - DBoesch ;;; ;;; Fehler: Je nach Grössenverhältnissen bei Bögen zwischen der Oberen- und Unteren-Linie werden die Böschungen nicht akkurat gesetzt. ;;; ;;; Böschungslinien zwischen/von/an 3D-Polylinien werden bei nicht Z-Parallelen-BKS falsch berechnet. ;;; ;;; Wenn ACAD keinen Schnittpunkt berechnen kann, kann die Mehrfachauswahl auch keinen Schnittpunkt erkennen und die Linie so nicht erstellt werden ;;; ;;; Autor: Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt ;;; ;;; Die Funktionen (GetVecLst) und (GetCooLst) wurden auf Basis der ;;; ;;; Vectorize-LISP von Richard Willis aka Didge (The Swamp) aufgebaut ;;; ;;; URL: Inspiriert durch: https://www.cadwiesel.de/index.php?hp=downloads&anzeigedatei=downloads&download_id=136 ;;; ;;; https://www.theswamp.org/index.php?topic=20878.msg255063 ;;; ;;; Version: 1.0 -> 2021/August ;;; ;;; Erstellung und erst Version ;;; ;;; 1.1 -> 2021/Oktober ;;; ;;; Einbau Linien dehen bei ungleichheit ;;; ;;; 2.0 -> 2023/Januar ;;; ;;; Generalüberarbeitung, benutzung von Splines, geschlossener Linien und Gliederung in einzelne Unterfunktionen ;;; ;;; Umstellung Nutzereingaben als Argumente und einführung Vorschaufenster (Dialog) ;;; ;;; 3.0 -> 2023/März ;;; ;;; Einbau Mehrfachauswahl Ober/Unterkannte und berechnung neuer zusammenhängender Linie, anpassung Dialog auf Mehrfachauswahl ;;; ;;; 3.1 -> 2023/Juni ;;; ;;; Fehlerbehebung bei ungleichlangen 3D-Polylinien ;;; ;;; Argumente: DefaultLayerNew --> Speichert den Standard-Layer für neue Top-+LowLinien | Typ: Sting ;;; ;;; DefaultLayerBoe --> Speichert den Standard-Layer für die Böschungslinien | Typ: Sting ;;; ;;; DefaultSpace --> Speichert den Standard-Abstand der Böschungslinien | Typ: - nil für Dynamisch ;;; ;;; - Integer/Real für spezifischen Wert ;;; ;;; Variablen: TopLine --> Objektname der Oberkante ;;; ;;; LowLine --> Objektname der Unterkante ;;; ;;; NewTop --> T wenn neue Oberkannte erstellt wurde ;;; ;;; NewLow --> T wenn neue Unterkannte erstellt wurde ;;; ;;; Layer --> Kontrolliert und setzt den Layer ;;; ;;; BoeLst --> Liste mit den Koordinaten der Böschungslinien ;;; ;;; UC --> Angabe der Bestätigung im Dialogfenster ;;; ;;; Code: (defun L-Boeschung ( DefaultLayerNew DefaultLayerBoe DefaultSpace / TopLine LowLine NewTop NewLow Layer BoeLst UC ) ;;; Begin nach den def's der Unterfunktionen ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;; Befehl: L-Boeschung |-> GetLines ;;; ;;; Zweck: Bereitstellen der Oberen und Unteren Linien ;;; ;;; Funktionen: (SELLINES . 0) ;;; ;;; (MAKELINE . 2) ;;; ;;; Autor: Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt ;;; ;;; Datum: 2021/August ;;; ;;; Angepasst - 2023/Januar ;;; ;;; Erweitert - 2023/März ;;; ;;; Argumente: Eingabe ohne Argumente ;;; ;;; Variablen: - ;;; ;;; Code: (defun GetLines ( / );Begin nach den def's der Unterfunktionen ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;; Befehl: L-Boeschung |-> GetLines |-> SelLines ;;; ;;; Zweck: Auswahl der Oberen und Unteren Linien ;;; ;;; Funktionen: Keine Unterfunktionen ;;; ;;; Autor: Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt ;;; ;;; Datum: 2023/März ;;; ;;; Argumente: Eingabe ohne Argumente ;;; ;;; Variablen: - ;;; ;;; Code: (defun SelLines ( / ) (if (listp (while (and (/= TopLine "Mehrere") (or (not TopLine) (not (or (eq (cdr (assoc 0 (entget (car TopLine)))) "LWPOLYLINE") (eq (cdr (assoc 0 (entget (car TopLine)))) "POLYLINE") (eq (cdr (assoc 0 (entget (car TopLine)))) "SPLINE") );end or );end not );end or );end and (initget "Mehrere") (setq TopLine (entsel "\n'Eine' obere Grenzkante wählen oder [Mehrere]: ")) );end while );end listp (setq TopLine (list (ssadd (car TopLine)))) (progn (setq TopLine nil) (princ "\nMehrere obere Grenzkanten wählen:") (setq TopLine (ssget "_+.:E:S" '((-4 . "")))) (redraw (ssname TopLine 0) 3) (setq TopLine (list (ssadd (ssname TopLine 0)(ssget "_+.:E" (list (assoc 0 (entget (ssname TopLine 0))))))(car (ssnamex TopLine 0)))) (redraw (cadadr TopLine) 4) );end progn );end if (if (listp (while (and (/= LowLine "Mehrere") (or (not LowLine) (ssmemb (car LowLine)(car TopLine)) (not (or (eq (cdr (assoc 0 (entget (car LowLine)))) "LWPOLYLINE") (eq (cdr (assoc 0 (entget (car LowLine)))) "POLYLINE") (eq (cdr (assoc 0 (entget (car LowLine)))) "SPLINE") );end or );end not );end or );end and (initget "Mehrere") (setq LowLine (entsel "\n'Eine' untere Grenzkante wählen oder [Mehrere]: ")) );end while );end listp (setq LowLine (list (ssadd (car LowLine)))) (progn (setq LowLine nil) (princ "\nMehrere untere Grenzkanten wählen:") (while (or (not LowLine)(ssmemb (ssname LowLine 0)(car TopLine))) (setq LowLine (ssget "_+.:E:S" '((-4 . "")))) );end while (redraw (ssname LowLine 0) 3) (setq LowLine (list (ssadd (ssname LowLine 0)(ssget "_+.:E" (list (assoc 0 (entget (ssname LowLine 0))))))(car (ssnamex LowLine 0)))) (redraw (cadadr LowLine) 4) );end progn );end if (and TopLine LowLine) );end defun ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;; Befehl: L-Boeschung |-> GetLines |-> MakeLine ;;; ;;; Zweck: Berechnet und Erstellt eine neue Linie aus den ausgwählten Segmenten der Linien ;;; ;;; Funktionen: Keine Unterfunktionen ;;; ;;; Autor: Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt ;;; ;;; Datum: 2023/April ;;; ;;; Argumente: ss --> SelectionSet der Mehrfachauswahl ;;; ;;; Frst --> ssnamex-Informationen der als erstes ausgewählten Linie ;;; ;;; Variablen: i --> Speichert Indexnummern und Intersection-Koordinaten zwischen ;;; ;;; Lst --> Liste mit den ssnamex-Informationen aller Entitys aus ss ;;; ;;; iLst --> Liste mit allen Intersection-Params einer Entity ;;; ;;; P --> Speichert Params und Punktkoordinaten zwischen ;;; ;;; PP --> Param des PickPoints ;;; ;;; PLst --> Liste mit den Entitynamen und den dazugehörien, relevanten Intersection-Params ;;; ;;; Nxt --> Temporäre Liste mit Segemntkoordinaten oder neuer Entity während foreach ;;; ;;; Line --> Entity der neuen, zusammengesetzten Linie ;;; ;;; Func-Key: Ent ;;; ;;; Nxt ;;; ;;; P ;;; ;;; Code: (defun MakeLine ( ss Frst / i Lst iLst P PP PLst Nxt Line Ent ) (repeat (setq i (sslength ss)) (setq Lst (cons (car (ssnamex ss (setq i (1- i)))) Lst)) );end repeat (setq Lst (subst Frst (last Lst) Lst)) (foreach Ent Lst (foreach Nxt (vl-remove Ent Lst) (if (setq i (vlax-invoke (vlax-ename->vla-object (nth 1 Ent)) 'intersectWith (vlax-ename->vla-object (nth 1 Nxt)) acExtendNone)) (repeat (/ (length i) 3) (setq iLst (cons (vlax-curve-getParamAtPoint (vlax-ename->vla-object (nth 1 Ent))(list (car i)(cadr i)(caddr i))) iLst) i (cdddr i) );end setq );end repeat );end if );end foreach (if iLst (progn (if (and (not (member (setq P (vlax-curve-getStartParam (vlax-ename->vla-object (nth 1 Ent)))) iLst)) (not (vlax-curve-isClosed (vlax-ename->vla-object (nth 1 Ent)))) );end and (setq iLst (cons P iLst)) );end if (if (and (not (member (setq P (vlax-curve-getEndParam (vlax-ename->vla-object (nth 1 Ent)))) iLst)) (not (vlax-curve-isClosed (vlax-ename->vla-object (nth 1 Ent)))) );end and (setq iLst (cons P iLst)) );end if (setq PP (vlax-curve-getParamAtPoint (vlax-ename->vla-object (nth 1 Ent)) (vlax-curve-getClosestPointToProjection (vlax-ename->vla-object (nth 1 Ent)) (cadr (nth 3 Ent)) (trans '(0 0 1) 1 0 T) );end vlax-curve-getClosestPointToProjection );end vlax-curve-getParamAtPoint iLst (cons PP iLst) );end setq (if (not (setq i (cadr (member PP (vl-sort iLst '<))))) (setq i (car (vl-sort iLst '<))) );end if (setq P i) (if (not (setq i (cadr (member PP (vl-sort iLst '>))))) (setq i (car (vl-sort iLst '>))) );end if (setq P (cons i P) PLst (cons (list (nth 1 Ent)(car P)(cdr P)) PLst) iLst nil PP nil P nil i nil );end setq );end progn );end if );end foreach (if (and PLst (setq ss (ssadd))) (foreach Ent PLst (if (= (cdr (assoc 0 (entget (car Ent)))) "POLYLINE") (progn (if (and (vlax-curve-isClosed (vlax-ename->vla-object (car Ent)))(> (cadr Ent)(caddr Ent))) (progn (setq Nxt (list (vlax-curve-getPointAtParam (vlax-ename->vla-object (car Ent))(caddr Ent))) P (fix (caddr Ent)) );end setq (while (>= P (vlax-curve-getStartParam (vlax-ename->vla-object (car Ent)))) (setq Nxt (cons (vlax-curve-getPointAtParam (vlax-ename->vla-object (car Ent)) P) Nxt) P (1- P) );end setq );end while (setq P (vlax-curve-getEndParam (vlax-ename->vla-object (car Ent)))) (while (> P (cadr Ent)) (setq Nxt (cons (vlax-curve-getPointAtParam (vlax-ename->vla-object (car Ent)) P) Nxt) P (1- P) );end setq );end while (setq Nxt (cons (vlax-curve-getPointAtParam (vlax-ename->vla-object (car Ent))(cadr Ent)) Nxt)) );end progn (progn (setq Nxt (list (vlax-curve-getPointAtParam (vlax-ename->vla-object (car Ent))(caddr Ent))) P (fix (caddr Ent)) );end setq (while (> P (cadr Ent)) (setq Nxt (cons (vlax-curve-getPointAtParam (vlax-ename->vla-object (car Ent)) P) Nxt) P (1- P) );end setq );end while (setq Nxt (cons (vlax-curve-getPointAtParam (vlax-ename->vla-object (car Ent))(cadr Ent)) Nxt)) );end progn );end cond (entmake (list '(0 . "POLYLINE") '(100 . "AcDbEntity") (assoc 8 (entget (car Ent))) '(100 . "AcDb3dPolyline") '(66 . 1) '(10 0.0 0.0 0.0) '(70 . 8) (assoc 210 (entget (car Ent))) );end list );end entmake (foreach P Nxt (entmake (list '(0 . "VERTEX") '(100 . "AcDbEntity") '(100 . "AcDbVertex") '(100 . "AcDb3dPolylineVertex") (cons 10 P) '(70 . 32) );end list );end entmake );end foreach (entmake (list '(0 . "SEQEND")'(100 . "AcDbNxtity"))) (setq PLst (subst (entlast) Ent PLst) ss (ssadd (entlast) ss) );end setq );end progn (progn (setq Nxt (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object (car Ent))))) (cond ((and (vlax-curve-isClosed (vlax-ename->vla-object Nxt))(> (cadr Ent)(caddr Ent))) (vl-cmdf "_.BREAK" Nxt (trans (vlax-curve-getPointAtParam (vlax-ename->vla-object Nxt)(cadr Ent)) 0 1) (trans (vlax-curve-getPointAtParam (vlax-ename->vla-object Nxt)(caddr Ent)) 0 1) );end vl-cmdf (if (entget Nxt) (setq PLst (subst Nxt Ent PLst) ss (ssadd Nxt ss) );end setq (setq PLst (vl-remove Ent PLst)) );end if );end ((and (vlax-curve-isClosed (vlax-ename->vla-object Nxt))(= (vlax-curve-getStartParam (vlax-ename->vla-object Nxt))(cadr Ent))) (setq P (trans (vlax-curve-getPointAtParam (vlax-ename->vla-object Nxt)(cadr Ent)) 0 1)) (vl-cmdf "_.BREAK" Nxt (trans (vlax-curve-getPointAtParam (vlax-ename->vla-object Nxt)(caddr Ent)) 0 1) (trans (vlax-curve-getPointAtParam (vlax-ename->vla-object Nxt)(+ (caddr Ent) 0.0001)) 0 1) );end vl-cmdf (vl-cmdf "_.BREAK" Nxt (trans (vlax-curve-getStartPoint (vlax-ename->vla-object Nxt)) 0 1) P );end vl-cmdf (if (entget Nxt) (setq PLst (subst Nxt Ent PLst) ss (ssadd Nxt ss) );end setq (setq PLst (vl-remove Ent PLst)) );end if );end (T (setq P (trans (vlax-curve-getPointAtParam (vlax-ename->vla-object Nxt)(caddr Ent)) 0 1)) (vl-cmdf "_.BREAK" Nxt (trans (vlax-curve-getStartPoint (vlax-ename->vla-object Nxt)) 0 1) (trans (vlax-curve-getPointAtParam (vlax-ename->vla-object Nxt)(cadr Ent)) 0 1) );end vl-cmdf (vl-cmdf "_.BREAK" Nxt P (trans (vlax-curve-getEndPoint (vlax-ename->vla-object Nxt)) 0 1) );end vl-cmdf (if (entget Nxt) (setq PLst (subst Nxt Ent PLst) ss (ssadd Nxt ss) );end setq (setq PLst (vl-remove Ent PLst)) );end if );end );end cond );end progn );end if );end foreach );end if (if ss (if (= (sslength ss) 1) (setq Line (ssname ss 0)) (progn (setvar 'QAFLAGS 1) (vl-cmdf "_.JOIN" ss "") (setvar 'QAFLAGS 0) (foreach Ent PLst (if (entget Ent) (if Line (if (> (vlax-curve-getEndParam (vlax-ename->vla-object Ent))(vlax-curve-getEndParam (vlax-ename->vla-object Line))) (setq Line Ent) (entdel Ent) );end if (setq Line Ent) );end if );end if );end foreach );end progn );end if );end if Line );end defun ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;;Weiter mit GetLines (if (SelLines) (progn (if (= (sslength (car TopLine)) 1) (setq TopLine (ssname (car TopLine) 0)) (setq TopLine (MakeLine (car TopLine)(cadr TopLine)) NewTop T );end setq );end if (if (= (sslength (car LowLine)) 1) (setq LowLine (ssname (car LowLine) 0)) (setq LowLine (MakeLine (car LowLine)(cadr LowLine)) NewLow T );end setq );end if );end progn );end if (and TopLine LowLine) );end defun ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;; Befehl: L-Boeschung |-> CheckDir ;;; ;;; Zweck: Kontolliert die Laufrichtung der Linien und dreht die LowLine bei ungleichheit um ;;; ;;; Funktionen: (ISDIRCW? . 1) ;;; ;;; Autor: Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt ;;; ;;; Datum: 2023/Januar ;;; ;;; Argumente: Eingabe ohne Argumente ;;; ;;; Variablen: - ;;; ;;; Code: (defun CheckDir ( / );;; Begin nach den def's der Unterfunktionen ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;; Befehl: L-Boeschung |-> CheckDir |-> IsDirCW ;;; ;;; Zweck: Kontolliert die Curve im Uhrzeigersinn läuft ;;; ;;; Funktionen: Keine Unterfunktionen ;;; ;;; Autor: Marko_ribar (AutoCAD Comunity Forum) ;;; ;;; Angepasst - Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt ;;; ;;; URL: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/polyline-direction-clockwise-or-counterclockwise/td-p/6050612 ;;; ;;; Datum: 2016/Februar ;;; ;;; Angepasst - 2023/Januar ;;; ;;; Argumente: Ent --> Entityname der Top- oder Lowline ;;; ;;; Variablen: Data --> Speichert Objektdaten von Ent ;;; ;;; Coo --> X/Y Koordinaten einer LWP ;;; ;;; CooLst --> Liste mit den Koordinaten ;;; ;;; Ret --> Rückgabewert positiv oder negativ ;;; ;;; Func-Key: x ;;; ;;; y ;;; ;;; Code: (defun IsDirCW? ( Ent / Data Coo CooLst Ret x y ) (cond ((= (cdr (assoc 0 (entget Ent))) "LWPOLYLINE") (setq Data (entget Ent)) (while (setq Coo (assoc 10 Data)) (setq Data (cdr (member Coo Data)) CooLst (append CooLst (list (list (cadr Coo)(caddr Coo)(cdr (assoc 38 (entget Ent)))))) );end setq );end while );end ((= (cdr (assoc 0 (entget Ent))) "POLYLINE") (while (= (cdr (assoc 0 (setq Data (entget (setq Ent (entnext Ent)))))) "VERTEX") (if (and (/= (cdr (assoc 70 Data)) 16) (/= (cdr (assoc 70 Data)) 48) );end and (setq CooLst (append CooLst (list (cdr (assoc 10 Data))))) );end if );end while );end ((= (cdr (assoc 0 (entget Ent))) "SPLINE") (setq CooLst (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10))(entget Ent)))) );end );end cond (vl-catch-all-apply 'minusp (list (if (not (equal 0.0 (setq Ret (apply '+ (mapcar '(lambda ( x y )(- (* (car x)(cadr y))(* (car y)(cadr x)))) (setq CooLst (mapcar '(lambda ( x y )(mapcar '- y x)) (mapcar '(lambda ( x )(car CooLst)) CooLst) (cdr (reverse (cons (car CooLst)(reverse CooLst)))) );end mapcar );end setq (cdr (reverse (cons (car CooLst)(reverse CooLst)))) );end mapcar );end apply );end setq 1e-6 );end equal );end not Ret nil );end if );end list );end vl-catch-all-apply );end defun ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;;Weiter mit CheckDir (if (or (vlax-curve-isClosed TopLine)(vlax-curve-isClosed LowLine)) (if (not (eq (IsDirCW? TopLine)(IsDirCW? LowLine))) (if (eq (cdr (assoc 0 (entget LowLine))) "SPLINE") (vl-cmdf "_.SPLINEDIT" LowLine "_REVERSE" "_EXIT") (vl-cmdf "_.PEDIT" LowLine "_REVERSE" "_EXIT") );end if );end if (if (> (distance (vlax-curve-getStartPoint (vlax-ename->vla-object TopLine))(vlax-curve-getStartPoint (vlax-ename->vla-object LowLine))) (distance (vlax-curve-getStartPoint (vlax-ename->vla-object TopLine))(vlax-curve-getEndPoint (vlax-ename->vla-object LowLine))) );end > (if (eq (cdr (assoc 0 (entget LowLine))) "SPLINE") (vl-cmdf "_.SPLINEDIT" LowLine "_REVERSE" "_EXIT") (vl-cmdf "_.PEDIT" LowLine "_REVERSE" "_EXIT") );end if );end if );end if );end defun ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;; Befehl: L-Boeschung |-> BoeschLst ;;; ;;; Zweck: Berechnen der Linien mit einem Definierten- oder Dynamischen-Abstand (wenn Dynamisch = 1/3 der aktuellen Strichlänge). ;;; ;;; Die berechneten Koordinaten werden in einer verschachtelten Liste gespeichert und Ausgegeben ;;; ;;; Die Linien werden von der Oberkante zum nächstgelegenen Punkt auf einer Projektion der Unterkante gelegt. ;;; ;;; Werden bei dynamischem Abstand die Abstände auf der Unterkante zu gross, ;;; ;;; werden erst die Abstände auf der Oberkante verkürzt oder in einem zweiten Schritt ;;; ;;; die Linien von der Unterkante her berechnet. ;;; ;;; Durch den Count werden die Linien abwechselnd lang und kurz erstellt. ;;; ;;; Die kurzen Linien werden mittig zwischen die Letzte und die nächste Linie gesetzt. ;;; ;;; Der ganze Rechenprozess berechnet die Linien immer Vorgreifend und passt sie dann nochmals an. NextP1 zu P1 zu LastP1. ;;; ;;; Funktionen: (ISONCU? . 2) ;;; ;;; (ISOVERCU? . 2) ;;; ;;; Autor: Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt ;;; ;;; Datum: 2021/August ;;; ;;; Angepasst - 2023/Januar ;;; ;;; Argumente: Eingabe ohne Argumente ;;; ;;; Variablen: Count --> Zähler der Linien (für kurz und lang) ;;; ;;; TSpace --> Abstand vom Anfang der Oberkante bis zum aktuellen Punkt ;;; ;;; P1 --> Aktueller Koordinatenpunkt auf der Oberkante ;;; ;;; P2 --> Aktueller Koordinatenpunkt auf der Unterkante ;;; ;;; LastP1 --> Letzter Koordinatenpunkt auf der Oberkante ;;; ;;; LastP2 --> Letzter Koordinatenpunkt auf der Unterkante ;;; ;;; Space --> Abstand zwischen den Linien ;;; ;;; NextP1 --> Nächster Koordinatenpunkt auf der Oberkante ;;; ;;; NextP2 --> Nächster Koordinatenpunkt auf der Oberkante ;;; ;;; P3 --> Aktueller Koordinatenpunkt zwischen Ober- und Unterkante ;;; ;;; Func-Key: x ;;; ;;; Code: (defun BoeschLst ( DSpace / Count TSpace P1 P2 LastP1 LastP2 Space NextP1 NextP2 P3 CooLst x ) ;;; Begin nach den def's der Unterfunktionen ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;; Befehl: L-Boeschung |-> BoeschLst |-> IsOnCu? ;;; ;;; Zweck: Kontrolliert ob der nächste Punkt noch auf der Curve liegt ;;; ;;; Funktionen: Keine Unterfunktionen ;;; ;;; Autor: Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt ;;; ;;; Datum: 2023/Januar ;;; ;;; Argumente: Obj --> Linien Objekt ;;; ;;; Pkt --> Nächster Punkt ;;; ;;; Variablen: - ;;; ;;; Code: (defun IsOnCu? ( Obj Pkt / ) (if (or (= (vl-catch-all-apply 'vlax-curve-getDistAtPoint (list Obj Pkt)) 0.0) (not (vl-catch-all-apply 'vlax-curve-getDistAtPoint (list Obj Pkt))) );end or (setq Pkt nil) );end if Pkt );end defun ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;; Befehl: L-Boeschung |-> BoeschLst |-> IsOverCu? ;;; ;;; Zweck: Kontrolliert ob der nächste Punkt auf geschlossenen Curves bereits über dem Startpunkt liegt ;;; ;;; Funktionen: Keine Unterfunktionen ;;; ;;; Autor: Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt ;;; ;;; Datum: 2023/Januar ;;; ;;; Argumente: Pkt1 --> Zu kontrollierender neuer Punkt ;;; ;;; Pkt2 --> Vorheriger Punkt (LastP) ;;; ;;; Variablen: Ret --> Return als Ausgabe ;;; ;;; Code: (defun IsOverCu? ( Pkt1 Pkt2 / Ret ) (if (>= (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) Pkt1) (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) Pkt2) );end >= (setq Ret (+ (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) Pkt2) (/ (- (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) Pkt1) (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) Pkt2) );end - 2.0 );end / );end + );end setq (setq Ret (if (> (- (vlax-curve-getDistAtParam (vlax-ename->vla-object LowLine) (vlax-curve-getEndParam (vlax-ename->vla-object LowLine)) );end vlax-curve-getDistAtParam (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) Pkt2) );end - (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) Pkt1) );end > (+ (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) Pkt2) (/ (- (+ (vlax-curve-getDistAtParam (vlax-ename->vla-object LowLine) (vlax-curve-getEndParam (vlax-ename->vla-object LowLine)) );end vlax-curve-getDistAtParam (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) Pkt1) );end + (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) Pkt2) );end - 2.0 );end / );end + (- (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) Pkt1) (/ (- (+ (vlax-curve-getDistAtParam (vlax-ename->vla-object LowLine) (vlax-curve-getEndParam (vlax-ename->vla-object LowLine)) );end vlax-curve-getDistAtParam (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) Pkt1) );end + (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) Pkt2) );end - 2.0 );end / );end - );end if );end setq );end if Ret );end defun ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;;Weiter mit BoeschLst (setq Count 0 TSpace 0 P1 (vlax-curve-getStartPoint (vlax-ename->vla-object TopLine)) P2 (vlax-curve-getClosestPointToProjection (vlax-ename->vla-object LowLine) P1 (trans '(0 0 1) 1 0 T)) LastP1 P1 LastP2 P2 );end setq (while P1 (if (equal (/ Count 2.0)(fix (/ Count 2.0)) 0.001) ;|;--==Durchgehende Linien Start==--;|; (progn (setq Space (if DSpace DSpace (/ (distance P1 P2) 3.0))) (if (< Space 0.025)(setq Space 0.025)) (setq NextP1 (IsOnCu? (vlax-ename->vla-object TopLine) (vlax-curve-getPointAtDist (vlax-ename->vla-object TopLine) (+ TSpace Space) );end vlax-curve-getPointAtDist );end IsOnCu? );end setq (if NextP1 (progn (setq NextP2 (vlax-curve-getClosestPointToProjection (vlax-ename->vla-object LowLine) NextP1 (trans '(0 0 1) 1 0 T))) (if (and (not DSpace) (> (- (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) NextP2) (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) P2) );end - (/ (distance P1 P2) 2.5) );end > );end and (progn (setq Space (/ Space 2.0)) (if (< Space 0.025)(setq Space 0.025)) (setq NextP1 (vlax-curve-getPointAtDist (vlax-ename->vla-object TopLine) (+ TSpace Space) );end vlax-curve-getPointAtDist NextP2 (vlax-curve-getClosestPointToProjection (vlax-ename->vla-object LowLine) NextP1 (trans '(0 0 1) 1 0 T)) );end setq );end progn );end if );end progn );end if );end progn ;|;--==Durchgehende Linien Ende==--;|; ;|;--== Halbe Linien Start ==--;|; (progn (setq NextP1 (IsOnCu? (vlax-ename->vla-object TopLine) (vlax-curve-getPointAtDist (vlax-ename->vla-object TopLine) (+ TSpace Space) );end vlax-curve-getPointAtDist );end IsOnCu? );end setq (if NextP1 (progn (setq NextP2 (vlax-curve-getClosestPointToProjection (vlax-ename->vla-object LowLine) NextP1 (trans '(0 0 1) 1 0 T))) (if (or (equal LastP2 NextP2 0.001) (> (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) LastP2) (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) NextP2) );end > );end or (if (not (<= (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) NextP2) (- (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) LastP2) (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) NextP2) );end - );end <= );end not (progn (setq NextP2 (IsOnCu? (vlax-ename->vla-object LowLine) (vlax-curve-getPointAtDist (vlax-ename->vla-object LowLine) (+ (/ Space 20.0) (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) LastP2) );end + );end vlax-curve-getPointAtDist );end IsOnCu? );end setq (if (not NextP2) (setq NextP2 (vlax-curve-getEndPoint (vlax-ename->vla-object LowLine))) );end if );end progn );end if );end if (if (and (not DSpace) (> (- (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) NextP2) (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) LastP2) );end - (distance LastP1 LastP2) );end > (> (distance LastP1 LastP2) 0.075) );end and (progn (setq NextP2 (vlax-curve-getPointAtDist (vlax-ename->vla-object LowLine) (+ (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) LastP2) (distance LastP1 LastP2) );end + );end vlax-curve-getPointAtDist );end setq (setq NextP1 (vlax-curve-getClosestPointToProjection (vlax-ename->vla-object TopLine) NextP2 (trans '(0 0 1) 1 0 T))) (if (or (equal LastP1 NextP1 0.001) (> (vlax-curve-getDistAtPoint (vlax-ename->vla-object TopLine) LastP1) (vlax-curve-getDistAtPoint (vlax-ename->vla-object TopLine) NextP1) );end > );end or (progn (setq NextP1 (vlax-curve-getPointAtDist (vlax-ename->vla-object TopLine) (+ (vlax-curve-getDistAtPoint (vlax-ename->vla-object TopLine) LastP1) 0.05 );end + );end vlax-curve-getPointAtDist NextP2 (vlax-curve-getPointAtDist (vlax-ename->vla-object LowLine) (+ (vlax-curve-getDistAtPoint (vlax-ename->vla-object LowLine) NextP2) 0.05 );end + );end vlax-curve-getPointAtDist );end setq );end progn );end if (setq P1 (vlax-curve-getPointAtDist (vlax-ename->vla-object TopLine) (+ (vlax-curve-getDistAtPoint (vlax-ename->vla-object TopLine) LastP1) (/ (- (vlax-curve-getDistAtPoint (vlax-ename->vla-object TopLine) NextP1) (vlax-curve-getDistAtPoint (vlax-ename->vla-object TopLine) LastP1) );end - 2.0 );end / );end + );end vlax-curve-getPointAtDist );end setq );end progn );end if (setq P2 (if (not (equal NextP2 LastP2 1e-8)) (vlax-curve-getPointAtDist (vlax-ename->vla-object LowLine) (IsOverCu? NextP2 LastP2) );end vlax-curve-getPointAtDist NextP2 );end if P3 (mapcar '(lambda (x)(/ x 2))(mapcar '+ P1 P2)) );end setq );end progn (setq P1 (if (vlax-curve-isClosed TopLine) (vlax-curve-getPointAtDist (vlax-ename->vla-object TopLine) (+ (vlax-curve-getDistAtPoint (vlax-ename->vla-object TopLine) LastP1) (/ (- (vlax-curve-getDistAtParam (vlax-ename->vla-object TopLine) (vlax-curve-getEndParam (vlax-ename->vla-object TopLine)) );end vlax-curve-getDistAtParam (vlax-curve-getDistAtPoint (vlax-ename->vla-object TopLine) LastP1) );end - 2.0 );end / );end + );end vlax-curve-getPointAtDist P1 );end if P2 (if (vlax-curve-isClosed TopLine) (vlax-curve-getPointAtDist (vlax-ename->vla-object LowLine) (IsOverCu? (vlax-curve-getClosestPointToProjection (vlax-ename->vla-object LowLine) (vlax-curve-getStartPoint (vlax-ename->vla-object TopLine)) (trans '(0 0 1) 1 0 T) );vlax-curve-getClosestPointToProjection LastP2 );end IsOverCu? );end vlax-curve-getPointAtDist P2 );end if P3 (mapcar '(lambda (x)(/ x 2))(mapcar '+ P1 P2)) );end setq );end if );end progn ;|;--== Halbe Linien Ende ==--;|; );end if (if (/= Count 0) (if (equal (/ Count 2.0)(fix (/ Count 2.0)) 0.001) (setq CooLst (append CooLst (list (list P1 P2)))) (setq CooLst (append CooLst (list (list P1 P3)))) );end if );end if (if NextP1 (setq TSpace (vlax-curve-getDistAtPoint (vlax-ename->vla-object TopLine) NextP1)) (setq TSpace (+ TSpace Space)) );end if (setq Count (1+ Count) LastP1 P1 LastP2 P2 P1 NextP1 P2 NextP2 );end setq );end while (if (and (vlax-curve-isClosed TopLine) (not (equal (/ (length CooLst) 2.0)(fix (/ (length CooLst) 2.0)) 0.001)) );end and (setq CooLst (cons (list (vlax-curve-getStartPoint (vlax-ename->vla-object TopLine)) (vlax-curve-getClosestPointToProjection (vlax-ename->vla-object LowLine) (vlax-curve-getStartPoint (vlax-ename->vla-object TopLine)) (trans '(0 0 1) 1 0 T) );end vlax-curve-getClosestPointToProjection );end list CooLst );end cons );end setq );end if CooLst );end defun ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;; Befehl: L-Boeschung |-> WriteDialog ;;; ;;; Zweck: Erstelt eine temporäre Dcl-Datei ;;; ;;; Funktionen: Keine Unterfunktionen ;;; ;;; Autor: Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt ;;; ;;; Datum: 2023/Januar ;;; ;;; Argumente: Eingabe ohne Argumente ;;; ;;; Variablen: TmpDcl --> Angabe des .dcl Pfads ;;; ;;; File --> Das geöffnete File ;;; ;;; Time --> Zeitstempel zur Rückverfolgung ;;; ;;; Code: (defun WriteDialog ( / TmpDcl File Time ) (setq TmpDcl (vl-filename-mktemp "LISP-" nil ".dcl") File (open TmpDcl "w") Time (rtos (getvar 'CDATE) 2 4) Time (strcat (substr Time 7 2)"." (substr Time 5 2)"." (substr Time 1 4)" / " (substr Time 10 2)":" (substr Time 12 2)" Uhr" );end strcat );end setq (foreach Line (list "///Automatisch generiertes, temporäres DCL-File für die Böschungs-LISP." (strcat "///Erstellt durch: "(getvar 'LOGINNAME)) (strcat "///Erstellt am/um: "Time) (strcat "///Erstellt in: "(getvar 'DWGPREFIX)(getvar 'DWGNAME)) "///Sollte diese Datei nicht automatisch gelöscht worden sein, Bitte manuell löschen." "///---------------------------------------------------------------------------------------------------------------------------------------///" "DBoesch" "///---------------------------------------------------------------------------------------------------------------------------------------///" ": dialog {label = \"Böschungslinien erstellen:\";" " : row {" " : boxed_column {label = \"Vorschau:\";" " : image {key = \"Image\";" " color = -2;" " width = 66.67;" " height = 30.77;" " fixed_width = true;" " fixed_height = true;" " aspect_ratio = 1;" " alignment = centered;" " }//end image" " }//end boxed_column" " : column {" " : boxed_column {label = \"Optionen:\";" (if (or NewTop NewLow) (strcat " : boxed_column {label = \"Layer:\";" "\n" " : edit_box {label = \"Böschung:\";" "\n" " key = \"LayBoe\";" "\n" " alignment = left;" "\n" " }//end edit_box" "\n" " : edit_box {label = \"OK: // UK:\";" "\n" " key = \"LayNew\";" "\n" " alignment = left;" "\n" " }//end edit_box" "\n" " }//end boxed_column" "\n" " : toggle {label = \"Erstellte OK/UK behalten?:\";" "\n" " key = NewLine;" "\n" " }//end toggle" );end strcat (strcat " : edit_box {label = \"Layer:\";" "\n" " key = \"LayBoe\";" "\n" " alignment = left;" "\n" " }//end edit_box" );end strcat );end if " : boxed_column {label = \"Abstand:\";" " : row {" " : radio_button {label = \"Dynamisch\";" " key = \"Dyn\";" " }// end radio_button" " : radio_button {label = \"Festgelegt\";" " key = \"Fix\";" " }//end radio_button" " }//end row" " : edit_box {label = \"Abstand:\";" " key = \"Dst\";" " }//end edit_box" " }//end boxed_column" " : text {label = \"Der kleinstmögliche Abstand ist 0.025!\";" " alignment = centered;" " }//end text" " : spacer {height = 0.5;}" " : button {label = \"<= Aktualisieren\";" " key = \"Upd\";" " width = 25;" " height = 2;" " fixed_width = true;" " alignment = centered;" " }//end button" " : spacer {height = 0.5;}" " }//end boxed_column" " : boxed_column {" " : spacer {height = 0.5;}" " : button {label = \"Abbrechen\";" " key = \"cancel\";" " is_cancel = true;" " width = 25;" " height = 2;" " fixed_width = true;" " alignment = centered;" " }//end button" " : button {label = \"Erstellen\";" " key = \"accept\";" " width = 25;" " height = 2;" " fixed_width = true;" " is_default = false;" " alignment = centered;" " }//end button" " : spacer {height = 0.5;}" " }//end boxed_column" " }//end column" " }//end row" " : text {label = \"Copyright© 2023;\t\t\tArchäologische Bodenforschung Basel-Stadt;\t\t\tF.Bubendorf\";" " fixed_width = true;" " }//end text" "}//end dialog" "///---------------------------------------------------------------------------------------------------------------------------------------///" );end list (write-line Line File) );end foreach (close File) TmpDcl );end defun ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;; Befehl: L-Boeschung |-> LM:Popup ;;; ;;; Zweck: A wrapper for the WSH popup method to display a message box prompting the user. ;;; ;;; Funktionen: Keine Unterfunktionen ;;; ;;; Autor: Lee Mac / Lee Mac Programming ;;; ;;; URL: http://lee-mac.com/popup.html ;;; ;;; Datum: -/- ;;; ;;; Argumente: Ttl --> Angabe der "Fensterbezeichnung" ;;; ;;; Msg --> Angabe des Textes für das Fenster ;;; ;;; Bit --> Angebae des Bitcodes für definition der Fenstereigenschaften (siehe auch URL) ;;; ;;; Variablen: Wsh --> Das "wscript.shell" Objekt ;;; ;;; Rtn --> Die Ausgabe als Integer ;;; ;;; Code: (defun LM:Popup ( Ttl Msg Bit / Wsh Rtn ) (if (setq Wsh (vlax-create-object "wscript.shell")) (progn (setq Rtn (vl-catch-all-apply 'vlax-invoke-method (list Wsh 'POPUP Msg 0 Ttl Bit))) (vlax-release-object Wsh) (if (not (vl-catch-all-error-p Rtn)) Rtn) );end progn );end if );end defun ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;; Befehl: L-Boeschung |-> GetVecLst ;;; ;;; Zweck: Erstellen einer Liste mit den Pixeln der Vektoren ;;; ;;; Funktionen: (GETCOOLST . 1) ;;; ;;; Autor: Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt ;;; ;;; Datum: 2023/Januar ;;; ;;; Angepasst: 2023/März ;;; ;;; Argumente: LayNew --> Angabe des Layers neu erstellter Top+Low Linien ;;; ;;; LayBoe --> Angabe des Layers der Böschungslinien ;;; ;;; Top --> Entity der Oberenlinie (TopLine) ;;; ;;; Low --> Entity der Unterenlinie (LowLine) ;;; ;;; Boe --> Liste mit den Koordinaten der einzelnen Böschungslinien ;;; ;;; Variablen: CooLst --> Liste mit den Koordinaten ;;; ;;; BBox --> Liste mit den jeweils grössten X/Y Koordinaten ;;; ;;; ScMax --> Wert für die maximale Scalierung ;;; ;;; Xof --> X-Wert gegen die Verzerrung ;;; ;;; Yof --> Y-Wert gegen die Verzerrung ;;; ;;; Color --> Farbe des Layers als Integer (Ziel-Layer) ;;; ;;; VLst --> Liste mit den Werten der Vektoren ;;; ;;; Func-Key: Line ;;; ;;; x ;;; ;;; Ob ;;; ;;; x1 ;;; ;;; x2 ;;; ;;; Code: (defun GetVecLst ( LayNew LayBoe Top Low Boe / CooLst BBox ScMax Xof Yof Color VLst Line Ob x1 x2 ) ;;; Begin nach den def's der Unterfunktionen ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;; Befehl: L-Boeschung |-> GetVecLst |-> GetCooLst ;;; ;;; Zweck: Erstellen einer Koordinatenliste der Segmente der Oberen- und Unteren-Linie ;;; ;;; Funktionen: Keine Unterfunktionen ;;; ;;; Autor: Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt ;;; ;;; Datum: 2023/Januar ;;; ;;; Argumente: Ent --> Entityname der Top- oder Lowline ;;; ;;; Variablen: Data --> Speichert Objektdaten von Ent ;;; ;;; CooLst --> Liste mit den Koordinaten ;;; ;;; Nxt --> Die Nummer des Params oder Entnext von Ent für das durchgehen der Verteces ;;; ;;; Dst --> Distanz der Segmente ;;; ;;; Code: (defun GetCooLst ( Ent / Data CooLst Nxt Dst ) (cond ((= (cdr (assoc 0 (entget Ent))) "LWPOLYLINE") (repeat (1+ (setq Nxt (fix (vlax-curve-getEndParam (vlax-ename->vla-object Ent))))) (setq CooLst (append CooLst (list (vlax-curve-getPointAtParam (vlax-ename->vla-object Ent) Nxt))) Nxt (1- Nxt) );end setq );end repeat (setq CooLst (reverse CooLst)) (if (vlax-curve-isClosed (vlax-ename->vla-object Ent)) (setq CooLst (append CooLst (list (nth 0 CooLst)))) );end if );end ((= (cdr (assoc 0 (entget Ent))) "POLYLINE") (setq Nxt Ent) (while (= (cdr (assoc 0 (setq Data (entget (setq Nxt (entnext Nxt)))))) "VERTEX") (if (and (/= (cdr (assoc 70 Data)) 16) (/= (cdr (assoc 70 Data)) 48) );end and (setq CooLst (append CooLst (list (cdr (assoc 10 Data))))) );end if );end while (if (vlax-curve-isClosed (vlax-ename->vla-object Ent)) (setq CooLst (append CooLst (list (nth 0 CooLst)))) );end if );end ((= (cdr (assoc 0 (entget Ent))) "SPLINE") (setq Dst 0) (repeat 64 ;| <- Anzahl Segmente |; (setq CooLst (append CooLst (list (vlax-curve-getPointAtDist (vlax-ename->vla-object Ent) Dst))) Dst (+ Dst (/ (vlax-curve-getDistAtParam (vlax-ename->vla-object Ent) (vlax-curve-getEndParam (vlax-ename->vla-object Ent)) );end vlax-curve-getDistAtParam 64 ;| <- Anzahl Segmente |; );end / );end + );end setq );end repeat (setq CooLst (append CooLst (list (vlax-curve-getPointAtDist (vlax-ename->vla-object Ent) Dst)))) );end (T (setq CooLst nil)) );end cond CooLst );end defun ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;;Weiter mit GetVecLst (foreach Line Boe (setq Boe (subst (list (if (tblsearch "LAYER" LayBoe) (cdr (assoc 62 (tblsearch "LAYER" LayBoe))) 1 );end if Line );end list Line Boe );end subst );end setq );end foreach (setq CooLst (append (GetCooLst Top)(GetCooLst Low)) BBox (list (list (apply 'min (mapcar 'car (mapcar '(lambda ( x )(trans x 0 1)) CooLst))) (apply 'min (mapcar 'cadr (mapcar '(lambda ( x )(trans x 0 1)) CooLst))) );end list (list (apply 'max (mapcar 'car (mapcar '(lambda ( x )(trans x 0 1)) CooLst))) (apply 'max (mapcar 'cadr (mapcar '(lambda ( x )(trans x 0 1)) CooLst))) );end list );end list CooLst (list (list (if NewTop (if (tblsearch "LAYER" LayNew) (cdr (assoc 62 (tblsearch "LAYER" LayNew))) 1 );end if (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 (entget Top)))))) );end if (GetCooLst Top) );end list (list (if NewLow (if (tblsearch "LAYER" LayNew) (cdr (assoc 62 (tblsearch "LAYER" LayNew))) 1 );end if (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 (entget Low)))))) );end if (GetCooLst Low) );end list );end list CooLst (append CooLst Boe) ScMax (max (/ (- (car (cadr BBox))(car (car BBox))) 400) (/ (- (cadr (cadr BBox))(cadr (car BBox))) 400) );end max Xof (fix (/ (- 400 (/ (- (car (cadr BBox))(car (car BBox))) ScMax)) 2)) Yof (fix (/ (- 400 (/ (- (cadr (cadr BBox))(cadr (car BBox))) ScMax)) 2)) );end setq (foreach Ob CooLst (setq Color (car Ob) Ob (mapcar '(lambda ( x )(trans x 0 1))(cadr Ob)) VLst (append (mapcar '(lambda ( x1 x2 ) (list (fix (+ (/ (- (car x1)(car (car BBox))) ScMax) Xof)) (fix (- 400 (+ (/ (- (cadr x1)(cadr (car BBox))) ScMax) Yof))) (fix (+ (/ (- (car x2)(car (car BBox))) ScMax) Xof)) (fix (- 400 (+ (/ (- (cadr x2)(cadr (car BBox))) ScMax) Yof))) Color );end list );end lambda Ob (cdr Ob) );end mapcar VLst );end append );end setq );end foreach VLst );end defun ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;; Befehl: L-Boeschung |-> CheckLay ;;; ;;; Zweck: Kontrolliert ob der gewählte Layer vorhanden ist ;;; ;;; Funktionen: Keine Unterfunktionen ;;; ;;; Autor: Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt ;;; ;;; Datum: 2021/August ;;; ;;; Argumente: Lay --> Angabe des Layers ;;; ;;; Variablen: Layer --> Ausgabe des kontrollierten Layers ;;; ;;; Code: (defun CheckLay ( Lay Typ / Layer ) (if (not (tblsearch "LAYER" Lay)) (progn (setq Layer "0") (LM:Popup "LISP-Meldung" (strcat "Layer \"" Lay "\" ist in der Zeichnung nicht Vorhanden!\nDie " Typ " wird auf dem Layer \"0\" eingefügt.") (+ 0 48 4096) );end LM:Popup );end progn (setq Layer Lay) );end if Layer );end defun ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;; Befehl: L-Boeschung |-> Dialog ;;; ;;; Zweck: Steuerung des Dialogfensters ;;; ;;; Funktionen: (DRAWIMG . 2) ;;; ;;; Autor: Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt ;;; ;;; Datum: 2023/Januar ;;; ;;; Angepasst: 2023/März ;;; ;;; Argumente: LayNew --> Angabe des Layers neu erstellter Top+Low Linien ;;; ;;; LayBoe --> Angabe des Layers der Böschungslinien ;;; ;;; Space --> Angabe des Abstands ;;; ;;; Variablen: TmpDcl --> Angabe des .dcl Pfads ;;; ;;; dcl_id --> Angabe der Dialog ID ;;; ;;; Code: (defun Dialog ( LayNew LayBoe Space / TmpDcl dcl_id );;; Begin nach den def's der Unterfunktionen ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;; Befehl: L-Boeschung |-> Dialog |-> DrawImg ;;; ;;; Zweck: Erstellung des Image im Dialogfenster ;;; ;;; Funktionen: Keine Unterfunktionen ;;; ;;; Autor: Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt ;;; ;;; Datum: 2023/Januar ;;; ;;; Argumente: LayNew --> Angabe des Layers neu erstellter Top+Low Linien ;;; ;;; LayBoe --> Angabe des Layers der Böschungslinien ;;; ;;; Space --> Angabe des Abstands ;;; ;;; Variablen: - ;;; ;;; Func-Key: x ;;; ;;; Code: (defun DrawImg ( LayNew LayBoe Space / x ) (start_image "Image") (fill_image 0 0 (dimx_tile "Image")(dimy_tile "Image") -2) (foreach x (GetVecLst LayNew LayBoe TopLine LowLine (setq BoeLst (BoeschLst Space))) (vector_image (fix (* (car x)(/ (dimx_tile "Image") 401.))) (fix (* (cadr x)(/ (dimy_tile "Image") 401.))) (fix (* (caddr x)(/ (dimx_tile "Image") 401.))) (fix (* (cadddr x)(/ (dimy_tile "Image") 401.))) (last x) );end vector_image );end foreach (end_image) );end defun ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;;Weiter mit Dialog (setq dcl_id (load_dialog (setq TmpDcl (WriteDialog)))) (if (not (new_dialog "DBoesch" dcl_id)) (progn (vl-file-delete TmpDcl) (LM:Popup "LISP Meldung" (strcat "Es scheint einen Fehler bei der Erstellung" "\ndes Dialogfensters gegeben zu haben." "\n\nBöschungs-LISP wird beendet!" );end strcat (+ 0 16 4096) );end LM:Popup (exit) );end progn );end if (DrawImg LayNew LayBoe Space) (if (or NewTop NewLow) (progn (set_tile "LayNew" LayNew) (set_tile "NewLine" "1") );end progn );end if (action_tile "LayNew" "(setq LayNew $value)") (set_tile "LayBoe" LayBoe) (action_tile "LayBoe" "(setq LayBoe $value)") (if Space (progn (set_tile "Fix" "1") (set_tile "Dst" (rtos Space 2 3)) );end progn (progn (set_tile "Dyn" "1") (mode_tile "Dst" 1) );end progn );end if (action_tile "Dyn" "(mode_tile \"Dst\" 1)(setq Space nil)") (action_tile "Fix" (strcat "(mode_tile \"Dst\" 0)" "(mode_tile \"Dst\" 3)" "(setq Space (atof (get_tile \"Dst\")))" );end strcat );end action_tile (action_tile "Dst" "(setq Space (atof $value))") (action_tile "Upd" "(DrawImg LayNew LayBoe Space)") (action_tile "cancel" "(done_dialog)(setq UC nil)(if NewTop (entdel TopLine))(if NewLow (entdel LowLine))") (mode_tile "accept" 2) (action_tile "accept" (strcat "(cond ((and NewTop NewLow)" "(if (= (get_tile \"NewLine\") \"0\")" "(progn (entdel TopLine)(entdel LowLine))" "(progn" "(setq LayNew (CheckLay LayNew \"erstellte OK/UK\"))" "(setq TopLine (cdr (assoc 0 (entmod (subst (cons 8 LayNew)(assoc 8 (entget TopLine))(entget TopLine))))))" "(setq LowLine (cdr (assoc 0 (entmod (subst (cons 8 LayNew)(assoc 8 (entget LowLine))(entget LowLine))))))" ")";end progn ")";end if ")";end "(NewTop" "(if (= (get_tile \"NewLine\") \"0\")" "(entdel TopLine)" "(progn" "(setq LayNew (CheckLay LayNew \"erstellte OK\"))" "(setq TopLine (cdr (assoc 0 (entmod (subst (cons 8 LayNew)(assoc 8 (entget TopLine))(entget TopLine))))))" ")";end progn ")";end if ")";end "(NewLow" "(if (= (get_tile \"NewLine\") \"0\")" "(entdel LowLine)" "(progn" "(setq LayNew (CheckLay LayNew \"erstellte UK\"))" "(setq LowLine (cdr (assoc 0 (entmod (subst (cons 8 LayNew)(assoc 8 (entget LowLine))(entget LowLine))))))" ")";end progn ")";end if ")";end "(T \"\")" ")";end cond "(done_dialog)" "(setq UC T Layer (CheckLay LayBoe \"Böschung\"))" );end strcat );end action_tile (start_dialog) (unload_dialog dcl_id) (vl-file-delete TmpDcl) );end defun ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;; Befehl: L-Boeschung |-> MakeBoesch ;;; ;;; Zweck: Erstellt die Böschungslinien ;;; ;;; Funktionen: Keine Unterfunktionen ;;; ;;; Autor: Fabian Bubendorf / Archäologische Bodenforschung Basel-Stadt ;;; ;;; Datum: 2023/Januar ;;; ;;; Argumente: Lst --> Liste mit den Koordinaten der Böschungslinien ;;; ;;; Variablen: - ;;; ;;; Func-Key: Line ;;; ;;; Code: (defun MakeBoesch ( Lst / Line ) (foreach Line Lst (entmake (list '(0 . "LINE")(cons 8 Layer)(cons 10 (car Line))(cons 11 (cadr Line)))) );end foreach );end defun ;;; --==*==-- ------------------------------------------------- --==*==-- --=={ ABBS }==-- --==*==-- ------------------------------------------------- --==*==-- ;;; ;;; Weiter mit L-Boeschung (while (= 8 (logand 8 (getvar 'UNDOCTL)))(vla-endUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))) (vla-startUndoMark (vla-get-ActiveDocument (vlax-get-acad-object))) (if (GetLines) (progn (vl-load-com) (CheckDir) (Dialog DefaultLayerNew DefaultLayerBoe DefaultSpace) (if UC (MakeBoesch BoeLst)) );end progn );end if (while (= 8 (logand 8 (getvar 'UNDOCTL)))(vla-endUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))) (princ) );end defun ;;; --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --=={ ABBS }==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- --==*==-- ;;; (defun c:TestBoeschung ( / )(L-Boeschung "0" "0" nil))