587 lines
16 KiB
Common Lisp
587 lines
16 KiB
Common Lisp
(vl-load-com)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; SAFE UTIL
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun safe-num (x)
|
|
(if (numberp x) x 0.0)
|
|
)
|
|
|
|
(defun safe-vec (v)
|
|
(cond
|
|
((and (listp v) (>= (length v) 2))
|
|
(list (safe-num (car v)) (safe-num (cadr v))))
|
|
((listp v)
|
|
'(0.0 0.0))
|
|
(T '(0.0 0.0))
|
|
)
|
|
)
|
|
|
|
(defun clean-point (p)
|
|
(if (and p (listp p))
|
|
(list
|
|
(safe-num (car p))
|
|
(safe-num (cadr p))
|
|
)
|
|
'(0.0 0.0)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; LAYER MANAGEMENT
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun ensure-layer (name color / doc layers layerObj)
|
|
|
|
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
|
|
(setq layers (vla-get-Layers doc))
|
|
|
|
(if (not (tblsearch "LAYER" name))
|
|
(setq layerObj (vla-add layers name))
|
|
(setq layerObj (vla-item layers name))
|
|
)
|
|
|
|
(vla-put-Color layerObj color)
|
|
layerObj
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; GEOMETRY CORE
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun point-distance (a b)
|
|
(sqrt
|
|
(+ (expt (- (car a) (car b)) 2)
|
|
(expt (- (cadr a) (cadr b)) 2)))
|
|
)
|
|
|
|
(defun vec-sub (a b)
|
|
(setq a (safe-vec a))
|
|
(setq b (safe-vec b))
|
|
(list (- (car a) (car b))
|
|
(- (cadr a) (cadr b)))
|
|
)
|
|
|
|
(defun point-distance-segment (p a b / ap ab denom t-val proj)
|
|
(setq p (safe-vec p))
|
|
(setq a (safe-vec a))
|
|
(setq b (safe-vec b))
|
|
(setq ap (vec-sub p a))
|
|
(setq ab (vec-sub b a))
|
|
;; GUARD: ab muss eine Liste mit 2 Zahlen sein
|
|
(if (not (and (listp ab)
|
|
(= (length ab) 2)
|
|
(numberp (car ab))
|
|
(numberp (cadr ab))))
|
|
(point-distance p a) ;; Fallback
|
|
(progn
|
|
(setq denom (+ (* (car ab) (car ab))
|
|
(* (cadr ab) (cadr ab))))
|
|
(if (<= denom 1e-12)
|
|
(point-distance p a)
|
|
(progn
|
|
(setq t-val (/ (+ (* (car ap) (car ab))
|
|
(* (cadr ap) (cadr ab)))
|
|
denom))
|
|
(setq t-val (safe-num t-val))
|
|
(if (< t-val 0.0) (setq t-val 0.0))
|
|
(if (> t-val 1.0) (setq t-val 1.0))
|
|
(setq proj (list (+ (car a) (* t-val (car ab)))
|
|
(+ (cadr a) (* t-val (cadr ab)))))
|
|
(point-distance p proj)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;; Liegt ein Punkt strikt zwischen den Endpunkten einer Linie?
|
|
;; (nicht am Endpunkt, mit kleiner Toleranz für numerischen Drift)
|
|
(defun point-on-segment-interior (pt a b tol / t-val ab ap denom)
|
|
(setq ab (vec-sub b a))
|
|
(setq ap (vec-sub pt a))
|
|
(setq denom (+ (* (car ab) (car ab)) (* (cadr ab) (cadr ab))))
|
|
(if (<= denom 1e-12)
|
|
nil
|
|
(progn
|
|
(setq t-val (/ (+ (* (car ap) (car ab)) (* (cadr ap) (cadr ab))) denom))
|
|
;; "innen" = klar weg von beiden Endpunkten
|
|
(and (> t-val (/ tol (sqrt denom)))
|
|
(< t-val (- 1.0 (/ tol (sqrt denom)))))
|
|
)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Endpunkt-zu-Endpunkt Prüfung (Stoß-Erkennung)
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun endpoints-touch-raw (l1 l2 tol / p1 p2 p3 p4)
|
|
;; Rohpunkte direkt aus der Linienliste (clean-point bereits angewendet)
|
|
(setq p1 (clean-point (car l1)))
|
|
(setq p2 (clean-point (cadr l1)))
|
|
(setq p3 (clean-point (car l2)))
|
|
(setq p4 (clean-point (cadr l2)))
|
|
(cond
|
|
((< (point-distance p1 p3) tol) p1)
|
|
((< (point-distance p1 p4) tol) p1)
|
|
((< (point-distance p2 p3) tol) p2)
|
|
((< (point-distance p2 p4) tol) p2)
|
|
(T nil)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; INTERSECTION CORE (SAFE + TOLERANT)
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun intersect-lines (l1 l2 / o1 o2 result arr)
|
|
|
|
(setq o1 (vlax-ename->vla-object (caddr l1)))
|
|
(setq o2 (vlax-ename->vla-object (caddr l2)))
|
|
|
|
(setq result
|
|
(vl-catch-all-apply
|
|
'vla-IntersectWith
|
|
(list o1 o2 0)
|
|
)
|
|
)
|
|
|
|
(if (vl-catch-all-error-p result)
|
|
nil
|
|
(progn
|
|
|
|
(setq result
|
|
(vl-catch-all-apply 'vlax-variant-value (list result))
|
|
)
|
|
|
|
(if (vl-catch-all-error-p result)
|
|
(setq result (vla-IntersectWith o1 o2 0))
|
|
)
|
|
|
|
(setq arr
|
|
(vl-catch-all-apply 'vlax-safearray->list (list result))
|
|
)
|
|
|
|
(if (vl-catch-all-error-p arr)
|
|
nil
|
|
(if (>= (length arr) 3)
|
|
(list (nth 0 arr) (nth 1 arr) 0.0)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; PIPELINE INTERSECTION (MAIN BRAIN)
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; normalize-point ersatzlos streichen
|
|
|
|
(defun find-intersection (l1 l2 tol / p1 p2 p3 p4 ip touch-pt)
|
|
(if (not (and (listp l1) (listp (car l1))
|
|
(listp l2) (listp (car l2))))
|
|
nil
|
|
(progn
|
|
(setq p1 (clean-point (car l1)))
|
|
(setq p2 (clean-point (cadr l1)))
|
|
(setq p3 (clean-point (car l2)))
|
|
(setq p4 (clean-point (cadr l2)))
|
|
|
|
;; Schritt 1: Endpunkt-Stoß
|
|
(setq touch-pt (endpoints-touch-raw l1 l2 tol))
|
|
(if touch-pt
|
|
(cons touch-pt (classify-intersection touch-pt l1 l2 tol))
|
|
|
|
;; Schritt 2: Echter Schnitt
|
|
(progn
|
|
(setq ip (intersect-lines l1 l2))
|
|
(if ip
|
|
(progn
|
|
;; Sicherheitsnetz: liegt SP nahe einem Endpunkt?
|
|
(if (or (< (point-distance ip p1) tol)
|
|
(< (point-distance ip p2) tol)
|
|
(< (point-distance ip p3) tol)
|
|
(< (point-distance ip p4) tol))
|
|
(cons ip (classify-intersection ip l1 l2 tol))
|
|
(if (and (point-on-segment-interior ip p1 p2 tol)
|
|
(point-on-segment-interior ip p3 p4 tol))
|
|
(cons ip "Kreuzung")
|
|
(cons ip (classify-intersection ip l1 l2 tol))
|
|
)
|
|
)
|
|
)
|
|
;; Schritt 3: Toleranz-Fallback
|
|
(cond
|
|
((< (point-distance-segment p1 p3 p4) tol)
|
|
(cons p1 (classify-intersection p1 l1 l2 tol)))
|
|
((< (point-distance-segment p2 p3 p4) tol)
|
|
(cons p2 (classify-intersection p2 l1 l2 tol)))
|
|
((< (point-distance-segment p3 p1 p2) tol)
|
|
(cons p3 (classify-intersection p3 l1 l2 tol)))
|
|
((< (point-distance-segment p4 p1 p2) tol)
|
|
(cons p4 (classify-intersection p4 l1 l2 tol)))
|
|
(T nil)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; CLASSIFICATION
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun is-endpoint (pt line tol)
|
|
(or
|
|
(< (point-distance pt (car line)) tol)
|
|
(< (point-distance pt (cadr line)) tol)
|
|
)
|
|
)
|
|
|
|
(defun classify-intersection (pt l1 l2 tol / e1 e2)
|
|
|
|
(setq e1 (is-endpoint pt l1 tol))
|
|
(setq e2 (is-endpoint pt l2 tol))
|
|
|
|
(cond
|
|
((and e1 e2) "Eckverbindung")
|
|
((or e1 e2) "T-Verbindung")
|
|
(T "Kreuzung")
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; DEDUP
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun point-exists (pt list tol)
|
|
(vl-some
|
|
'(lambda (p)
|
|
(< (point-distance pt p) tol)
|
|
)
|
|
list
|
|
)
|
|
)
|
|
|
|
(defun count-by-type (lst typ)
|
|
(length
|
|
(vl-remove-if-not
|
|
'(lambda (p) (= (caddr p) typ))
|
|
lst
|
|
)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; DRAW
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun create-circle (pt radius layer)
|
|
(entmakex
|
|
(list
|
|
'(0 . "CIRCLE")
|
|
(cons 8 layer)
|
|
(cons 10 pt)
|
|
(cons 40 radius)
|
|
)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; INPUT
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun get-lines-by-layer (layers / ss i ent obj lines)
|
|
|
|
(setq lines '())
|
|
|
|
(foreach lay layers
|
|
(setq ss
|
|
(ssget "_X"
|
|
(list '(0 . "LINE") (cons 8 lay))
|
|
)
|
|
)
|
|
|
|
(if ss
|
|
(progn
|
|
(setq i 0)
|
|
(repeat (sslength ss)
|
|
|
|
(setq ent (ssname ss i))
|
|
(setq obj (vlax-ename->vla-object ent))
|
|
|
|
(setq lines
|
|
(cons
|
|
(list
|
|
(clean-point (vlax-get obj 'StartPoint))
|
|
(clean-point (vlax-get obj 'EndPoint))
|
|
ent
|
|
)
|
|
lines
|
|
)
|
|
)
|
|
|
|
(setq i (1+ i))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
lines
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; TEXTDATEI-EXPORT
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun write-report (all-pts filepath layers / f n-kr n-tv n-ek n-kontakt n-gesamt)
|
|
(setq n-kr (count-by-type all-pts "Kreuzung"))
|
|
(setq n-tv (count-by-type all-pts "T-Verbindung"))
|
|
(setq n-ek (count-by-type all-pts "Eckverbindung"))
|
|
(setq n-kontakt (+ n-tv n-ek))
|
|
(setq n-gesamt (length all-pts))
|
|
|
|
(setq f (open filepath "w"))
|
|
(if (not f)
|
|
(prompt (strcat "\nFehler: Datei konnte nicht erstellt werden: " filepath))
|
|
(progn
|
|
(write-line "================================================" f)
|
|
(write-line " VERBINDUNGSZAEHLER - ERGEBNIS" f)
|
|
(write-line "================================================" f)
|
|
(write-line "" f)
|
|
(write-line (strcat " Datum/Zeit : " (menucmd "M=$(edtime,$(getvar,DATE),DD.MM.YYYY HH:MM:SS)")) f)
|
|
(write-line (strcat " Zeichnung : " (vla-get-FullName (vla-get-ActiveDocument (vlax-get-acad-object)))) f)
|
|
;; Layer-Zeile im Report dynamisch:
|
|
(write-line
|
|
(strcat " Layer : "
|
|
(apply 'strcat
|
|
(cons (car layers)
|
|
(mapcar '(lambda (l) (strcat ", " l)) (cdr layers))
|
|
)
|
|
)
|
|
)
|
|
f
|
|
)
|
|
(write-line "" f)
|
|
(write-line "------------------------------------------------" f)
|
|
(write-line " VERBINDUNGSTYPEN" f)
|
|
(write-line "------------------------------------------------" f)
|
|
(write-line "" f)
|
|
(write-line (strcat " Kreuzungen : " (itoa n-kr)) f)
|
|
(write-line (strcat " T-Verbindungen : " (itoa n-tv)) f)
|
|
(write-line (strcat " Eckverbindungen : " (itoa n-ek)) f)
|
|
(write-line "" f)
|
|
(write-line "------------------------------------------------" f)
|
|
(write-line " SUMMEN" f)
|
|
(write-line "------------------------------------------------" f)
|
|
(write-line "" f)
|
|
(write-line (strcat " Kreuzungen : " (itoa n-kr)) f)
|
|
(write-line (strcat " Kontaktpunkte (T + Eck) : " (itoa n-kontakt)) f)
|
|
(write-line (strcat " davon T-Verbindungen : " (itoa n-tv)) f)
|
|
(write-line (strcat " davon Eckverbindungen : " (itoa n-ek)) f)
|
|
(write-line "" f)
|
|
(write-line (strcat " GESAMT : " (itoa n-gesamt)) f)
|
|
(write-line "" f)
|
|
(write-line "================================================" f)
|
|
(close f)
|
|
(prompt (strcat "\nBericht gespeichert: " filepath))
|
|
)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; INPUT MIT DEFAULTS
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun prompt-layers (default-layers / input parts result)
|
|
;; default-layers ist eine Liste z.B. '("D-1" "D-5")
|
|
(setq input
|
|
(getstring
|
|
(strcat "\nLayer (kommagetrennt) ["
|
|
(apply 'strcat
|
|
(cons (car default-layers)
|
|
(mapcar '(lambda (l) (strcat ", " l)) (cdr default-layers))
|
|
)
|
|
)
|
|
"]: ")
|
|
)
|
|
)
|
|
(if (= input "")
|
|
default-layers
|
|
;; Eingabe splitten an Komma, Whitespace trimmen
|
|
(progn
|
|
;; einfaches Splitten: Zeichen für Zeichen
|
|
(setq parts (split-string-by input ","))
|
|
(foreach p parts
|
|
(setq p (string-trim p))
|
|
(if (/= p "")
|
|
(setq result (cons p result))
|
|
)
|
|
)
|
|
(reverse result)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun prompt-tolerance (default-tol / input val)
|
|
(setq input
|
|
(getstring
|
|
(strcat "\nToleranz [" (rtos default-tol 2 2) "]: ")
|
|
)
|
|
)
|
|
(if (= input "")
|
|
default-tol
|
|
(progn
|
|
(setq val (atof input))
|
|
(if (> val 0.0)
|
|
val
|
|
(progn
|
|
(prompt (strcat "\nUngueltige Toleranz, verwende Default: " (rtos default-tol 2 2)))
|
|
default-tol
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;; Hilfsfunktion: String an Trennzeichen splitten
|
|
(defun split-string-by (str sep / result current i ch)
|
|
(setq result '())
|
|
(setq current "")
|
|
(setq i 0)
|
|
(while (< i (strlen str))
|
|
(setq ch (substr str (1+ i) 1))
|
|
(if (= ch sep)
|
|
(progn
|
|
(setq result (cons current result))
|
|
(setq current "")
|
|
)
|
|
(setq current (strcat current ch))
|
|
)
|
|
(setq i (1+ i))
|
|
)
|
|
;; letztes Segment
|
|
(setq result (cons current result))
|
|
(reverse result)
|
|
)
|
|
|
|
;; Hilfsfunktion: führende/nachfolgende Leerzeichen entfernen
|
|
(defun string-trim (str / i j)
|
|
(setq i 1)
|
|
(setq j (strlen str))
|
|
(while (and (<= i j) (= (substr str i 1) " "))
|
|
(setq i (1+ i))
|
|
)
|
|
(while (and (>= j i) (= (substr str j 1) " "))
|
|
(setq j (1- j))
|
|
)
|
|
(if (> j (1- i))
|
|
(substr str i (- (1+ j) i))
|
|
""
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; MAIN COMMAND
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun c:VZAEHLER (/ layers tol radius lines i j l1 l2 pt typ all-pts result report-path)
|
|
|
|
;; ── Defaults ────────────────────────────────────────────
|
|
(setq default-layers '("D-1" "D-5"))
|
|
(setq default-tol 0.5)
|
|
|
|
;; ── Benutzereingabe ──────────────────────────────────────
|
|
(prompt "\n===== VERBINDUNGSZAEHLER =====")
|
|
(setq layers (prompt-layers default-layers))
|
|
(setq tol (prompt-tolerance default-tol))
|
|
(setq radius 100)
|
|
|
|
(prompt (strcat "\nLayer : "))
|
|
(foreach l layers (prompt (strcat l " ")))
|
|
(prompt (strcat "\nToleranz : " (rtos tol 2 2)))
|
|
(prompt "\n------------------------------")
|
|
|
|
;; ── Logik ────────────────────────────────────
|
|
|
|
(setq all-pts '())
|
|
(setq lines (get-lines-by-layer layers))
|
|
|
|
(ensure-layer "D-KREUZUNG" 1)
|
|
(ensure-layer "D-T_VERBINDUNG" 3)
|
|
(ensure-layer "D-ECKVERBINDUNG" 5)
|
|
|
|
(prompt (strcat "\nLinien gefunden: " (itoa (length lines))))
|
|
|
|
(setq i 0)
|
|
|
|
(while (< i (length lines))
|
|
|
|
(setq j (+ i 1))
|
|
|
|
(while (< j (length lines))
|
|
|
|
(setq l1 (nth i lines))
|
|
(setq l2 (nth j lines))
|
|
|
|
(setq result (find-intersection l1 l2 tol))
|
|
(if result
|
|
(progn
|
|
(setq pt (car result)) ;; Punkt
|
|
(setq typ (cdr result)) ;; Typ — direkt aus find-intersection
|
|
(if (not (point-exists pt all-pts tol))
|
|
(progn
|
|
(setq all-pts (cons (list (car pt) (cadr pt) typ) all-pts))
|
|
(cond
|
|
((= typ "Kreuzung") (create-circle pt radius "D-KREUZUNG"))
|
|
((= typ "T-Verbindung") (create-circle pt radius "D-T_VERBINDUNG"))
|
|
((= typ "Eckverbindung") (create-circle pt radius "D-ECKVERBINDUNG"))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(setq j (1+ j))
|
|
)
|
|
|
|
(setq i (1+ i))
|
|
)
|
|
|
|
(prompt "\n\n===== ERGEBNIS =====")
|
|
(prompt (strcat "\nKreuzungen: " (itoa (count-by-type all-pts "Kreuzung"))))
|
|
(prompt (strcat "\nT-Verbindungen: " (itoa (count-by-type all-pts "T-Verbindung"))))
|
|
(prompt (strcat "\nEckverbindungen: " (itoa (count-by-type all-pts "Eckverbindung"))))
|
|
(prompt (strcat "\nGESAMT: " (itoa (length all-pts))))
|
|
|
|
;; ── Report schreiben ──────────────────────────────────────
|
|
(setq dwg-name
|
|
(vla-get-Name (vla-get-ActiveDocument (vlax-get-acad-object)))
|
|
)
|
|
;; ".dwg" abschneiden falls vorhanden
|
|
(if (wcmatch dwg-name "*.dwg")
|
|
(setq dwg-name (substr dwg-name 1 (- (strlen dwg-name) 4)))
|
|
)
|
|
(setq timestamp
|
|
(menucmd "M=$(edtime,$(getvar,DATE),YYYYMMDD-HHMMSS)")
|
|
)
|
|
(setq report-path
|
|
(strcat
|
|
(vla-get-Path (vla-get-ActiveDocument (vlax-get-acad-object)))
|
|
"\\"
|
|
dwg-name
|
|
"_"
|
|
timestamp
|
|
"_vzaehler.txt"
|
|
)
|
|
)
|
|
|
|
(write-report all-pts report-path layers)
|
|
|
|
(princ)
|
|
) |