AutoCad Profilprogramm zum lesen und schreiben
Nach dem ich neulich hier gelesen habe, dass Ihr die Profildaten beim AutoCad
mit Script eingebt, das vorher mit Excel konvertiert, hab ich mal gekramt,und gehackt…
von der Seite kopieren abspeichern als: PROFIL1-0.lsp
Bedienung: Autocad (dürfte ab R14 gehen) starten,
Befehl: (load“<Laufwerkbst>\\<Pfad>\\PROFIL1-0.lsp“)
Die Kommandos sind: PROFIL (ließt *.dat) und PT(schreibt *.dat )
wenn’s Fragen oder Fehlerberichte gibt Email schicken.
viel Spaß EMU
;;ABHIER KOPIEREN
;**********************************************************************************
; *
; PROFIL1-0.lsp *
; Releas 1.0 *
; AutoLispprogramm ab ACAD R14/INTELLICAD *
; Erstellt/Bugreport an: Emanuel.Strobel@yahoo.com *
; Releas 1.0 23.12.2006 *
; *
; 100% FREIWARE * KEINE GARANTIE FÜR SCHÄDEN *
; *
;**********************************************************************************
;**********************************************************************************
;********************************C: PROFIL ************************************
;**********************************************************************************
;**********************************************************************************
;AutoCad Kommando: PROFIL erstellt Profil aus Datei *.dat
;Tip Profil-PLINE nicht schliesen,dann kannst Du mit Kommando: ._pedit Kurve angleichen
;**********************************************************************************
(defun C:PROFIL ( / FILENAME LISTE PNTLIST LASTN MID BASEPNT SCALEINP SCALE CLAY XOFS YOFS N PT1 PT2 NDX CNT TMP ATP NTP)
(setvar "cmdecho" 0)
(setq FILENAME (getfiled "Profil wählen" "" "dat" 4))
(prompt "Bitte warten...")
(setq LISTE (READFILE FILENAME)
BASEPNT nil
SCALEINP nil
)
(if LISTE
(progn
(setq ATP (CALCTHICKNESS LISTE (CALCMAX-X LISTE)))
(setq NTP (getreal (strcat "\rDicke des Profils <" (rtos (* ATP 100) 2) "%>: ")))
(if (not NTP) (setq NTP ATP) (setq NTP (/ NTP 100)))
(graphscr)
(setq BASEPNT (getpoint "\nBasispunkt des Profils <0,0>: "))
(if (not BASEPNT) (setq BASEPNT (list 0 0 0)))
(setq PNTLIST '()
SCALE 100.0
SCALEINP (getreal (strcat "\nSkalierung des Profils <" (rtos SCALE 2) ">: "))
CLAY (getvar "CLAYER")
XOFS (car BASEPNT)
YOFS (cadr BASEPNT)
CNT 0
TMP 0
NDX 0
)
(if SCALEINP (setq SCALE SCALEINP))
(foreach N LISTE
(setq PT1 (CALCPNT N SCALE ATP NTP)
PNTLIST (append PNTLIST (LIST PT1))
)
)
(make-lwpoly PNTLIST) (setq LASTN (entlast))
(setq N (nth (/ (length LISTE) 2) LISTE)
PT1 (CALCPNT N SCALE ATP NTP)
)
(setq PT2 (CALCPNT (nth NDX LISTE) SCALE ATP NTP))
(entmake (list (cons 0 "LINE") (cons 8 "SEHNEN") (cons 10 PT1)
(cons 11 PT2) (cons 62 1)))
(prompt (strcat "\nProfil " FILENAME " mit " (itoa (length LISTE))
" Vectoren fertig."))
)
(prompt (strcat "\nDatei " FILENAME " nicht gefunden! "))
)
(setq MID (Get_Mid_Coor (car PT1) (cadr PT1) (car PT2) (cadr PT2)))
(initget 128 "J N")
(setq CUR (getkword "\nBeplankung erstellen? <J/N>: "))
(cond
((= CUR "J") (setq FACKTOR (getreal "Beplankungsabzug eingeben: "))(command "._offset" FACKTOR LASTN MID ""))
((= CUR "N") (princ))
(t (princ))
)
(setvar "cmdecho" 1)
(princ)
)
(defun SCAN (ZEILE / SL CH SP EP)
(setq SL (strlen ZEILE)
CH " "
SP 1
EP 1
)
(while (and (= CH " ") (< SP SL))
(setq CH (substr ZEILE SP 1))
(setq SP (1+ SP))
)
(setq EP SP
SP (1- SP)
)
(while (and (/= CH " ") (< EP SL))
(setq CH (substr ZEILE EP 1)
EP (1+ EP)
)
)
(setq EP (1- EP))
(list SP EP)
)
;****************************************************************************
(defun READFILE (FILENAME / LISTE FILE LINE BST X Y)
(setq LISTE nil
FILE (open FILENAME "r")
)
(if FILE
(progn
(setq LINE (read-line FILE))
(setq LINE (read-line FILE))
(while (and LINE (> (strlen LINE) 10))
(setq BST (SCAN LINE)
X (atof (substr LINE (car BST)))
LINE (substr LINE (cadr BST))
BST (SCAN LINE)
Y (atof (substr LINE (car BST)))
LISTE (append LISTE (list (list X Y)))
LINE (read-line FILE)
)
)
(close FILE)
)
)
LISTE
)
;****************************************************************************
(defun CALCPNT (PTLIST SCALE ATP NTP / Y FAC)
(setq Y (cadr PTLIST)
FAC (/ NTP ATP)
Y (* Y FAC)
)
(list (+ (* (car PTLIST) SCALE) XOFS) (+ (* Y SCALE) YOFS) 0)
)
;****************************************************************************
(defun CALCMAX-X (LISTE / TMP N)
(setq TMP 0)
(foreach N LISTE
(if (> (car N) TMP) (setq TMP (car N)))
)
TMP
)
;****************************************************************************
(defun CALCTHICKNESS (LISTE HIGHX / UP DN HI TMP N)
(setq UP 0
DN (- (length LISTE) 1)
HI 0
TMP 0
)
(foreach N LISTE
(if (< (car N) HIGHX)
(progn
(setq TMP (distance (nth UP LISTE) (nth DN LISTE)))
(if (> TMP HI) (setq HI TMP))
(setq UP (1+ UP)
DN (1- DN)
)
)
)
)
HI
)
;**********************************************************************************
;********************************make-lwpoly***************************************
;**********************************************************************************
(defun make-lwpoly( LISTE / VERTEX p1 p2 p3 p4 p5 p6 ee N pkt)
(setq VERTEX (length LISTE)
p1 (cons 0 "LWPOLYLINE")
p2 (cons 100 "AcDbEntity")
p4 (cons 100 "AcDbPolyline")
pl (cons 8 "PROFILE")
pf (cons 62 0)
p6 (cons 70 0)
p5 (cons 90 VERTEX)
ee nil
ee (list p6 p5 pf pl p4 p2 p1)
INDEX 0
)
(repeat VERTEX
(progn
(setq pkt (list 10 (car(nth INDEX LISTE)) (cadr(nth INDEX LISTE)))
ee (cons pkt ee)
INDEX (1+ INDEX)
)
)
)(setq ee (reverse ee))(entmake ee)
)
;**********************************************************************************
;********************************Get_Mid_Coor**************************************
;**********************************************************************************
(Defun Get_Mid_Coor (X1 Y1 X2 Y2 / pntls)
(setq pntls (list (/ (+ X1 X2) 2) (/ (+ Y1 Y2) 2) 0.0)
)pntls
)
;**********************************************************************************
;**********************************C:PT********************************************
;**********************************************************************************
;**********************************************************************************
;Kommando: PT Erstellt Profildatei *.dat
; >>>>> ACHTUNG!! PROFIL AUF 0,0 SCHIEBEN!!!<<<<<<<<<<<<<<<<
; >>>>> ACHTUNG!! POLYLINIE AM SCHWANZ OFFEN LASSEN ABER
; PUNKTE ÜBEREINANDER LASSEN!!!<<<<<<<<<<<<<<<<
;**********************************************************************************
(defun C:PT (/ ent en0 en1 what outf pt1 file pfn)
(setvar "cmdecho" 0)
(setq en0 (entsel "\nProfil wählen: ")
en1 (car en0)
ent (entget en1)
what (cdr (assoc 0 ent))
pfn (getstring"Profilnamen eingeben <profil_01.dat>:"))
(if (= pfn "") (setq pfn "profil_01"))
(setq file (getfiled "Speichen unter" pfn "dat" 1))
(prompt "Bitte warten...")
(if(= what "LWPOLYLINE")
(progn
(setq outf (open file "w"))
(princ pfn outf)
(princ "\n" outf)
(while (setq pt1 (assoc 10 ent))
(setq ent (cdr (member pt1 ent)))
(princ (rtos (/ (cadr pt1)100) 2 5) outf)
(princ " " outf)
(princ (rtos (/ (caddr pt1)100) 2 5) outf)
(princ "\n" outf)
)
(close outf)
)
(alert "Keine LWPolyline ausgewählt.")
)
(setvar "cmdecho" 1)
(princ)
)
;EOF PROFIL1-0.LSP ****************************************************************
;**********************************************************************************
;**********************************************************************************
Nach dem ich neulich hier gelesen habe, dass Ihr die Profildaten beim AutoCad
mit Script eingebt, das vorher mit Excel konvertiert, hab ich mal gekramt,und gehackt…
von der Seite kopieren abspeichern als: PROFIL1-0.lsp
Bedienung: Autocad (dürfte ab R14 gehen) starten,
Befehl: (load“<Laufwerkbst>\\<Pfad>\\PROFIL1-0.lsp“)
Die Kommandos sind: PROFIL (ließt *.dat) und PT(schreibt *.dat )
wenn’s Fragen oder Fehlerberichte gibt Email schicken.
viel Spaß EMU
;;ABHIER KOPIEREN
;**********************************************************************************
; *
; PROFIL1-0.lsp *
; Releas 1.0 *
; AutoLispprogramm ab ACAD R14/INTELLICAD *
; Erstellt/Bugreport an: Emanuel.Strobel@yahoo.com *
; Releas 1.0 23.12.2006 *
; *
; 100% FREIWARE * KEINE GARANTIE FÜR SCHÄDEN *
; *
;**********************************************************************************
;**********************************************************************************
;********************************C: PROFIL ************************************
;**********************************************************************************
;**********************************************************************************
;AutoCad Kommando: PROFIL erstellt Profil aus Datei *.dat
;Tip Profil-PLINE nicht schliesen,dann kannst Du mit Kommando: ._pedit Kurve angleichen
;**********************************************************************************
(defun C:PROFIL ( / FILENAME LISTE PNTLIST LASTN MID BASEPNT SCALEINP SCALE CLAY XOFS YOFS N PT1 PT2 NDX CNT TMP ATP NTP)
(setvar "cmdecho" 0)
(setq FILENAME (getfiled "Profil wählen" "" "dat" 4))
(prompt "Bitte warten...")
(setq LISTE (READFILE FILENAME)
BASEPNT nil
SCALEINP nil
)
(if LISTE
(progn
(setq ATP (CALCTHICKNESS LISTE (CALCMAX-X LISTE)))
(setq NTP (getreal (strcat "\rDicke des Profils <" (rtos (* ATP 100) 2) "%>: ")))
(if (not NTP) (setq NTP ATP) (setq NTP (/ NTP 100)))
(graphscr)
(setq BASEPNT (getpoint "\nBasispunkt des Profils <0,0>: "))
(if (not BASEPNT) (setq BASEPNT (list 0 0 0)))
(setq PNTLIST '()
SCALE 100.0
SCALEINP (getreal (strcat "\nSkalierung des Profils <" (rtos SCALE 2) ">: "))
CLAY (getvar "CLAYER")
XOFS (car BASEPNT)
YOFS (cadr BASEPNT)
CNT 0
TMP 0
NDX 0
)
(if SCALEINP (setq SCALE SCALEINP))
(foreach N LISTE
(setq PT1 (CALCPNT N SCALE ATP NTP)
PNTLIST (append PNTLIST (LIST PT1))
)
)
(make-lwpoly PNTLIST) (setq LASTN (entlast))
(setq N (nth (/ (length LISTE) 2) LISTE)
PT1 (CALCPNT N SCALE ATP NTP)
)
(setq PT2 (CALCPNT (nth NDX LISTE) SCALE ATP NTP))
(entmake (list (cons 0 "LINE") (cons 8 "SEHNEN") (cons 10 PT1)
(cons 11 PT2) (cons 62 1)))
(prompt (strcat "\nProfil " FILENAME " mit " (itoa (length LISTE))
" Vectoren fertig."))
)
(prompt (strcat "\nDatei " FILENAME " nicht gefunden! "))
)
(setq MID (Get_Mid_Coor (car PT1) (cadr PT1) (car PT2) (cadr PT2)))
(initget 128 "J N")
(setq CUR (getkword "\nBeplankung erstellen? <J/N>: "))
(cond
((= CUR "J") (setq FACKTOR (getreal "Beplankungsabzug eingeben: "))(command "._offset" FACKTOR LASTN MID ""))
((= CUR "N") (princ))
(t (princ))
)
(setvar "cmdecho" 1)
(princ)
)
(defun SCAN (ZEILE / SL CH SP EP)
(setq SL (strlen ZEILE)
CH " "
SP 1
EP 1
)
(while (and (= CH " ") (< SP SL))
(setq CH (substr ZEILE SP 1))
(setq SP (1+ SP))
)
(setq EP SP
SP (1- SP)
)
(while (and (/= CH " ") (< EP SL))
(setq CH (substr ZEILE EP 1)
EP (1+ EP)
)
)
(setq EP (1- EP))
(list SP EP)
)
;****************************************************************************
(defun READFILE (FILENAME / LISTE FILE LINE BST X Y)
(setq LISTE nil
FILE (open FILENAME "r")
)
(if FILE
(progn
(setq LINE (read-line FILE))
(setq LINE (read-line FILE))
(while (and LINE (> (strlen LINE) 10))
(setq BST (SCAN LINE)
X (atof (substr LINE (car BST)))
LINE (substr LINE (cadr BST))
BST (SCAN LINE)
Y (atof (substr LINE (car BST)))
LISTE (append LISTE (list (list X Y)))
LINE (read-line FILE)
)
)
(close FILE)
)
)
LISTE
)
;****************************************************************************
(defun CALCPNT (PTLIST SCALE ATP NTP / Y FAC)
(setq Y (cadr PTLIST)
FAC (/ NTP ATP)
Y (* Y FAC)
)
(list (+ (* (car PTLIST) SCALE) XOFS) (+ (* Y SCALE) YOFS) 0)
)
;****************************************************************************
(defun CALCMAX-X (LISTE / TMP N)
(setq TMP 0)
(foreach N LISTE
(if (> (car N) TMP) (setq TMP (car N)))
)
TMP
)
;****************************************************************************
(defun CALCTHICKNESS (LISTE HIGHX / UP DN HI TMP N)
(setq UP 0
DN (- (length LISTE) 1)
HI 0
TMP 0
)
(foreach N LISTE
(if (< (car N) HIGHX)
(progn
(setq TMP (distance (nth UP LISTE) (nth DN LISTE)))
(if (> TMP HI) (setq HI TMP))
(setq UP (1+ UP)
DN (1- DN)
)
)
)
)
HI
)
;**********************************************************************************
;********************************make-lwpoly***************************************
;**********************************************************************************
(defun make-lwpoly( LISTE / VERTEX p1 p2 p3 p4 p5 p6 ee N pkt)
(setq VERTEX (length LISTE)
p1 (cons 0 "LWPOLYLINE")
p2 (cons 100 "AcDbEntity")
p4 (cons 100 "AcDbPolyline")
pl (cons 8 "PROFILE")
pf (cons 62 0)
p6 (cons 70 0)
p5 (cons 90 VERTEX)
ee nil
ee (list p6 p5 pf pl p4 p2 p1)
INDEX 0
)
(repeat VERTEX
(progn
(setq pkt (list 10 (car(nth INDEX LISTE)) (cadr(nth INDEX LISTE)))
ee (cons pkt ee)
INDEX (1+ INDEX)
)
)
)(setq ee (reverse ee))(entmake ee)
)
;**********************************************************************************
;********************************Get_Mid_Coor**************************************
;**********************************************************************************
(Defun Get_Mid_Coor (X1 Y1 X2 Y2 / pntls)
(setq pntls (list (/ (+ X1 X2) 2) (/ (+ Y1 Y2) 2) 0.0)
)pntls
)
;**********************************************************************************
;**********************************C:PT********************************************
;**********************************************************************************
;**********************************************************************************
;Kommando: PT Erstellt Profildatei *.dat
; >>>>> ACHTUNG!! PROFIL AUF 0,0 SCHIEBEN!!!<<<<<<<<<<<<<<<<
; >>>>> ACHTUNG!! POLYLINIE AM SCHWANZ OFFEN LASSEN ABER
; PUNKTE ÜBEREINANDER LASSEN!!!<<<<<<<<<<<<<<<<
;**********************************************************************************
(defun C:PT (/ ent en0 en1 what outf pt1 file pfn)
(setvar "cmdecho" 0)
(setq en0 (entsel "\nProfil wählen: ")
en1 (car en0)
ent (entget en1)
what (cdr (assoc 0 ent))
pfn (getstring"Profilnamen eingeben <profil_01.dat>:"))
(if (= pfn "") (setq pfn "profil_01"))
(setq file (getfiled "Speichen unter" pfn "dat" 1))
(prompt "Bitte warten...")
(if(= what "LWPOLYLINE")
(progn
(setq outf (open file "w"))
(princ pfn outf)
(princ "\n" outf)
(while (setq pt1 (assoc 10 ent))
(setq ent (cdr (member pt1 ent)))
(princ (rtos (/ (cadr pt1)100) 2 5) outf)
(princ " " outf)
(princ (rtos (/ (caddr pt1)100) 2 5) outf)
(princ "\n" outf)
)
(close outf)
)
(alert "Keine LWPolyline ausgewählt.")
)
(setvar "cmdecho" 1)
(princ)
)
;EOF PROFIL1-0.LSP ****************************************************************
;**********************************************************************************
;**********************************************************************************
