Schoenenberger_Systeme_GmbH/dxfmakros
3
0
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects Releases Wiki Activity

Aus den Lisp Daten unter M:\ACADSST\MENU eine neue Standardlibrary mit Codedoku extrahiert

Browse Source
This commit is contained in:
Michael Stangl
2026-05-08 11:19:36 +02:00
parent 9fee0e1eb4
commit a3011e7c2a
19 changed files with 5509 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
doc/acadsst/MENU/laymr14.lsp
+462
View File
@@ -0,0 +1,462 @@
;............................................................
;: DATE : 92-01-01 Kunde: tewi :
;: Autor: Schmidt AutoCAD-Version 11 :
;: Version 1.1 ab Version 10 mit anpassen :
;: :
;: LAYM14.LSP Layer-Manager :
;:..........................................................:
(SPECIAL '(grp))
(DEFUN zoal () ;Zoom af
(SETQ vsiz (GETVAR "VIEWSIZE"))
(COMMAND "_ZOOM" "_V")
)
(DEFUN zovo () ;Zoom vorher, wenn m”glich
(IF (/= (GETVAR "VIEWSIZE") vsiz)
(COMMAND "_ZOOM" "_P")
)
)
(DEFUN mdis (/ mlau)
(SETQ mlau 26)
(GRTEXT 0 "LAY-MAN")
(GRTEXT 1 " ")
(GRTEXT 2 " ? ")
(GRTEXT 3 " SET ")
(GRTEXT 4 "COPY GR.")
(GRTEXT 5 "MOVE GR.")
(GRTEXT 6 "MOVE EL ")
(GRTEXT 7 "MOVE ALL")
(GRTEXT 8 "ON LAYER")
(GRTEXT 9 "OFF LAYR")
(GRTEXT 10 "TAU LAY.")
(GRTEXT 11 "FR LAYER")
(GRTEXT 12 "FR ALL ")
(GRTEXT 13 "DEL LAY.")
(GRTEXT 14 "LAY.SELE")
(GRTEXT 15 " ")
(GRTEXT 16 " ")
(GRTEXT 17 " ")
(GRTEXT 18 " ")
(GRTEXT 19 " ")
(GRTEXT 20 " ")
(GRTEXT 21 " ")
(GRTEXT 22 " ")
(GRTEXT 23 " ")
(GRTEXT 24 " ")
(GRTEXT 25 " ")
(WHILE (< mlau mlen)
(GRTEXT mlau " ")
(SETQ mlau (1+ mlau))
)
)
(DEFUN ssgad (nset gset / slau seln) ;SSET zu SSET addieren
(SETQ slau 0)
(IF (NULL (EVAL (READ gset)))(SET (READ gset)(SSADD)))
(WHILE (SETQ seln (SSNAME nset slau))
(SSADD seln (EVAL (READ gset)))
(REDRAW seln 3)
(SETQ slau (1+ slau))
)
)
(DEFUN ared (aset ltyp / asla asna) ;Ausleuchten von Elementen.
(SETQ asla 0)
(WHILE (SETQ asna (SSNAME aset asla))
(REDRAW asna ltyp)
(SETQ asla (1+ asla))
)
)
(DEFUN alay (txt) ;Layername filtern
(IF (SETQ akel (ENTSEL txt))
(CDR (ASSOC '8 (ENTGET (CAR akel))))
)
)
(defun alel (tele elna) ;Elemente filtern
(IF elna
(SSGET "X" (LIST (CONS '0 elna)(CONS '8 tele)))
(SSGET "X" (LIST (CONS '8 tele)))
)
)
(DEFUN lann (nwna ngna) ;Layer new name
(STRCAT (SUBSTR nwna 1 1) ngna (SUBSTR nwna 4))
)
(DEFUN laqu (/ lach) ;Layer Gruppenname
(SETQ lach "-"
last (SUBSTR (STRCASE (GETSTRING "Group-Letter: <_> ")) 1 2)
last (COND
((= (STRLEN last) 2) last)
((= (STRLEN last) 1) (STRCAT last lach))
( T (STRCAT lach lach))
)
)
)
(DEFUN ltes (tlay grou) ;ausschalt Kontrolle
(IF (OR (AND (= (SUBSTR (GETVAR "CLAYER") 2 2) tlay) grou)
(AND (= (GETVAR "CLAYER") tlay) (NOT grou))
)
(emsg "change first active layer")
T
)
)
(DEFUN layl (/ lext ltan) ;Layerliste
(SETQ ltan T)
(WHILE (SETQ lext (TBLNEXT "LAYER" ltan))
(SETQ laex (CONS (CONS (CDADR lext) (CDDR lext)) laex)
ltan NIL
)
)
)
(DEFUN ldis (/ run lauf llen) ;Layer am Seitenmenu anz.
(SETQ run T
lauf 0
llen (LENGTH clis)
)
(WHILE run
(WHILE (< lauf mlen)
(IF (< lpos llen)
(GRTEXT lauf (NTH lpos clis))
(GRTEXT lauf " ")
) ;Menuanzeige
(SETQ lauf (1+ lauf)
lpos (1+ lpos)
)
;um 1 erh”hen
)
(IF (> lpos mlen)
(GRTEXT mlen "Prev. ")
(GRTEXT mlen " ")
) ;R�ckschalten
(IF (> (- llen lpos) 0)
(GRTEXT (1+ mlen) "Next ")
(GRTEXT (1+ mlen) " ")
) ;Vorw„rtsschalten
(IF (= (CAR (SETQ antw (GRREAD))) 4)
(IF (< (CADR antw) mlen)
;wenn g�ltige Antwort
(IF (> (SETQ antw (+ (CADR antw)(- lpos lauf))) llen)
(SETQ antw NIL run NIL)
(SETQ run NIL
lpos (IF (= (- lpos mlen) (1- llen))
(- lpos mlen mlen)
(- lpos mlen)
)
)
)
(COND
((AND (= (CADR antw) mlen)(> lpos mlen))
;Vorher
(SETQ lpos (- lpos mlen mlen)
lauf 0
)
)
((AND (= (CADR antw) (1+ mlen))(> llen lpos))
;N„chst
(SETQ lauf 0)
)
(T (emsg "False Field !"))
)
)
(SETQ antw NIL run NIL)
)
)
)
(DEFUN lays (ein / clis lpos laex antw atly akly llau lcom) ;Layer schalten
(SETQ lpos 0)
(layl)
(IF ein
(FOREACH xpos laex
(IF (MINUSP (CDR (ASSOC 62 (CDR xpos))))
(SETQ clis (CONS (CAR xpos) clis))
)
)
(FOREACH xpos laex
(IF (= (CDR (ASSOC 70 (CDR xpos))) 65)
(SETQ clis (CONS (CAR xpos) clis))
)
)
)
(WHILE clis
(PRINC "\nSelect Layer from the Screen Menu: ")
(ldis)
(IF antw
(SETQ atly (NTH antw clis)
akly (CONS atly akly)
clis (APPEND (REVERSE (CDR (MEMBER atly (REVERSE clis))))
(CDR (MEMBER atly clis))
)
)
(SETQ clis NIL)
)
)
(IF akly
(PROGN
(SETQ llau 0
lcom (IF ein "_ON" "_T")
)
(PRINC "\n\nPlease wait ...")
(COMMAND "_LAYER")
(REPEAT (LENGTH akly)
(COMMAND lcom (NTH llau akly))
(SETQ llau (1+ llau))
)
(COMMAND "")
)
(emsg "Nothing selected!")
)
)
(DEFUN laye (/ lacg lauf lant) ;Layer neuer Auswahlsatz
(SETQ lacg (SSLENGTH chgr)
lauf 0
)
(REPEAT lacg
(IF (NOT (MEMBER (SETQ lant (CDR (ASSOC 8 (ENTGET
(SSNAME chgr lauf))))) lanl))
(SETQ lanl (CONS lant lanl))
)
(SETQ lauf (1+ lauf))
)
)
(DEFUN layc (/ lall lauf lane linf laco nlna chel laol nwel) ;Layer change
(SETQ lall (LENGTH lanl)
lauf 0
)
(REPEAT lall
(IF (NOT (ASSOC (lann (NTH lauf lanl) last) laex))
(SETQ lane (CONS (NTH lauf lanl) lane))
)
(SETQ lauf (1+ lauf))
)
(SETQ lall (LENGTH lane)
lauf 0
)
(REPEAT lall
(SETQ linf (CDR (ASSOC (NTH lauf lane) laex))
laco (IF (MINUSP (SETQ lico (CDR (ASSOC 62 linf))))(ABS lico) lico)
nlna (lann (NTH lauf lane) last)
)
(COMMAND "_LAYER" "_N" nlna "_CO" lico nlna "LT" (CDR (ASSOC 6 linf)) nlna "")
(SETQ lauf (1+ lauf))
)
(SETQ lall (SSLENGTH chgr)
lauf 0
)
(REPEAT lall
(SETQ chel (ENTGET (SSNAME chgr lauf))
laol (ASSOC 8 chel)
nwel (SUBST (CONS 8 (lann (CDR laol) last)) laol chel)
)
(ENTMOD nwel)
(SETQ lauf (1+ lauf))
)
)
(DEFUN lgrn (cona / lpos lgri clis lnwn lnaw lsta ltmp lntp ldtp lddb last) ;Layer Gruppenmanipulationen
(SETQ lpos 0)
(layl)
(FOREACH xpos laex
(IF (SETQ lgri (SUBSTR (CAR xpos) 2 2))
(IF clis
(IF (NOT (MEMBER lgri clis))
(SETQ clis (CONS lgri clis))
)
(SETQ clis (LIST lgri))
)
)
)
(IF clis
(PROGN
(PRINC "\nSelect group from the Screen Menu: ")
(ldis)
(IF antw
(PROGN
(SETQ lnwn (STRCAT "?" (NTH antw clis) "*"))
(COND
((= cona "_OFF")
(IF (ltes (NTH antw clis) T)
(COMMAND "_LAYER" "_OFF" lnwn "")
)
)
((= cona "DEL")
(SETQ lnaw (NTH antw clis)
lsta T
)
(zoal)
(WHILE (SETQ ltmp (TBLNEXT "LAYER" lsta))
(IF (= (SUBSTR (SETQ lntp (CDR (ASSOC 2 ltmp))) 2 2) lnaw)
(IF (SETQ ldtp (SSGET "X" (LIST (CONS 8 lntp))))
(ssgad ldtp "lddb")
)
)
(SETQ lsta NIL)
)
(IF lddb
(IF (ques "Delete this Elements?" NIL)
(COMMAND "_ERASE" lddb "")
(ared lddb 4)
)
)
(zovo)
)
((= cona "WAHL")
(SETQ lnaw (NTH antw clis)
lsta T
)
(WHILE (SETQ ltmp (TBLNEXT "LAYER" lsta))
(IF (= (SUBSTR (SETQ lntp (CDR (ASSOC 2 ltmp))) 2 2) lnaw)
(IF (SETQ ldtp (SSGET "X" (LIST (CONS 8 lntp))))
(ssgad ldtp "lddb")
)
)
(SETQ lsta NIL)
)
(IF lddb
(PROGN
(PRINC "\nThis Elements are now saved as !GRP")
(PRINC "\nPress any key to continue...")
(GRREAD)
(SETQ grp lddb)
(ared lddb 4)
)
(emsg "No elements found..!")
)
)
(T (COMMAND "_LAYER" cona lnwn ""))
)
)
(emsg "Nothing selected!")
)
)
)
)
(DEFUN laymanag (sele layn / vsiz elem elet akna akel akly clay lanl last) ;Hauptprogramm
(IF (NOT runm)
(pstart "Layer - Manager" "" '(("REGENMODE")))
)
(COND
((= sele 2)
(IF (SETQ akly (alay "\nObjekt wählen\n"))
(PRINC (STRCAT "\nElement ist auf Layer " akly))
)
)
((= sele 3)
(IF (SETQ akly (alay "\nZiel-Ebene wählen\n"))
(PROGN
(COMMAND "_LAYER" "_SET" akly "")
(SETQ cavar (SUBST (CONS "CLAYER" akly)
(ASSOC '"CLAYER" cavar) cavar)
)
)
)
)
((= sele 4)
(IF (SETQ elem (ssget))
(IF (SETQ akly (alay "\nObjekt auf dem Ziel-Ebene wählen\n"))
(COMMAND "_COPY" elem "" "@" "@" "_CHANGE" elem "" "_PROP" "_LA" akly "")
(emsg "Kein Layer gewählt! ")
)
(emsg "Kein Objekt gewählt! ")
)
)
((= sele 5)
(IF (SETQ elem (ssget))
(IF (SETQ akly (alay "\nObjekt auf dem Ziel-Ebene wählen\n"))
(COMMAND "_CHANGE" elem "" "_PROP" "_LA" akly "")
(emsg "Kein Layer gewählt")
)
(emsg "Kein Objekt gewählt")
)
)
((= sele 6)
(IF (SETQ akly (alay "\nZu änderndes Objekt wählen\n"))
(PROGN
(SETQ akna (CDR (ASSOC '0 (ENTGET (CAR akel)))))
(IF (SETQ elem (alel akly akna))
(IF (SETQ akly (alay "Select object on the target layer:\n"))
(PROGN
(zoal)
(ared elem 3)
(IF (ques (STRCAT "Layer von "
(COND
((= akna "LINE") "Line")
((= akna "CIRCLE") "Circle")
((= akna "ARC") "Arc")
((= akna "POINT") "Point")
((= akna "PLINE") "Polylie")
( T akna)
)
" ändern?") NIL)
(COMMAND "_CHANGE" elem "" "_PROP" "_LA" akly "")
(ared elem 4)
)
(zovo)
)
(emsg "Kein Layer gewählt")
)
)
)
(emsg "Kein Object gewählt")
)
)
((= sele 7)
(IF (SETQ akly (alay "\nDie zu ändernden Objekte wählen\n"))
(IF (SETQ elem (alel akly NIL))
(IF (SETQ akly (alay "Objekt auf der Ziel-Ebene wählen\n"))
(PROGN
(zoal)
(ared elem 3)
(IF (ques "Layer für diese Objekte ändern ?" NIL)
(COMMAND "_CHANGE" elem "" "_PROP" "_LA" akly "")
(ared elem 4)
)
(zovo)
)
(emsg "Kein Layer gewählt")
)
)
(emsg "Kein Objekt gewählt")
)
)
((= sele 8)(lays T))
((= sele 9)
(WHILE (SETQ akly (alay "\nLayer zum Ausblenden\n"))
(IF (ltes akly nil)
(COMMAND "_LAYER" "_OFF" akly "")
)
)
)
((= sele 10)(lays NIL))
((= sele 11)
(WHILE (SETQ akly (alay "\nLayer FRIEREN\n"))
(IF (ltes akly nil)
(COMMAND "_LAYER" "_FR" akly "")
)
)
)
((= sele 12)
(SETQ clay (alay "\nObjekt auf dem aktiven Layer der aktiv bleibt wählen\n"))
(COMMAND "_LAYER" "_SET" clay "_FR" "*" "")
)
)
(IF (NOT runm)
(pend)
)
)
(PRINC)
(PRINC "\n Layermanager loaded")
(PRINC)
doc/acadsst/MENU/ssg.lsp
+518
View File
@@ -0,0 +1,518 @@
(IF SPECIAL
(SPECIAL '(olde ptest cavar bell prna))
(DEFUN SPECIAL (x) nil)
)
(DEFUN pstart (tit qust setv / xlen xpos xvar)
(SETQ olde *ERROR*
*ERROR* (IF ptest NIL errhan)
cavar (APPEND '(("CLAYER")("CMDECHO"))
setv)
xlen (LENGTH cavar)
xpos 0
)
(REPEAT xlen
(SETQ xvar (CAR (NTH xpos cavar))
cavar (SUBST (CONS xvar (GETVAR xvar))
(NTH xpos cavar) cavar)
xpos (1+ xpos)
)
)
(SETVAR "CMDECHO" 0)
(COMMAND "_undo" "_G")
(GRAPHSCR)
(PROMPT (STRCAT "\n***** " tit " *****\n\n " qust))
(PRINC)
)
(DEFUN pend (/ xpos xlen xvar)
(IF cavar
(PROGN
(COMMAND)
(COMMAND "_undo" "_E")
(SETQ xpos 1
xlen (LENGTH cavar)
)
(IF (/= (GETVAR "CLAYER") (CAAR cavar))
(COMMAND "_LAYER" "_SE" (CDAR CAVAR) "")
)
(REPEAT (1- xlen)
(SETQ xvar (NTH xpos cavar)
xpos (1+ xpos)
)
(SETVAR (CAR xvar)(CDR xvar))
)
)
)
(IF olde (SETQ *ERROR* olde))
(PRINC)
)
(DEFUN errhan (em)
(IF (= em "Function cancelled")
(PRINC)
(PRINC em)
)
(GRTEXT)
(COMMAND)
(COMMAND)
(pend)
)
(DEFUN ques (dial defa) ;Std Abfrage
(IF defa
(PROGN
(INITGET 1 "Yes No Yes")
(= (GETKWORD (STRCAT "\n" dial " Y/N <Y>: ")) "No")
)
(PROGN
(INITGET 1 "Yes No No")
(= (GETKWORD (STRCAT "\n" dial " Y/N <Y>: ")) "Yes")
)
)
)
(DEFUN emsg (etxt)
(IF (NOT bell)(PROMPT "\007"))
(TERPRI)
(PROMPT etxt)
(TERPRI)
)
(DEFUN ques (dial defa) ;Std Abfrage
(IF defa
(PROGN
(INITGET 1 "Yes No Yes")
(= (GETKWORD (STRCAT "\n" dial " Y/N <Y>: ")) "No")
)
(PROGN
(INITGET 1 "Yes No No")
(= (GETKWORD (STRCAT "\n" dial " Y/N <N>: ")) "Yes")
)
)
)
(DEFUN renv (envn prnn / penv)
(IF (SETQ penv (GETENV envn))
(EVAL (STRCAT penv "" prnn))
(EVAL prnn)
)
)
(DEFUN C:PRG (/ nprg cprg prna)
(SETQ nprg (GETSTRING)
cprg (STRCAT "C:" nprg)
prna (renv "ACADLSP" nprg)
)
(IF (NULL (EVAL (READ cprg)))
(PROGN
(PRINC " loading...!\n")
(COND
((FINDFILE (STRCAT prna ".BI4"))
(LOAD prna ".BI4"))
((FINDFILE (STRCAT prna ".BI2"))
(LOAD prna ".BI2"))
((FINDFILE (STRCAT prna ".LSP"))
(LOAD prna ".LSP"))
( T (emsg "File not found"))
)
)
)
(PRINC)
)
(DEFUN C:ed (/ prnn)
(IF (NULL prna)
(SETQ prna "")
)
(SETQ prnn (GETSTRING
(STRCAT "Programname <" prna ">: ")))
(IF (AND (= (STRLEN prna) 0)(= (STRLEN prnn) 0))
(emsg "Name not allowed...")
(PROGN
(IF (> (STRLEN prnn) 0)
(SETQ prna (renv "ACADLSP" prnn))
)
(COMMAND "SHELL" (STRCAT "ED " prna ))
(INITGET 1 "Yes No Yes")
(IF (NOT (ques "Load the program" T))
(LOAD prna)
)
)
)
(PRINC)
)
;----------- Block einfuegen mit Layergenerierung ----2.8.92 AW
; KEINE DREHMOEGLICHKEIT !!!
(DEFUN c:symplac ( / einp); / einp ebene symname)
(SETQ einp (GETPOINT "\nInsert-Point: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp "" "" "0")
)
;----------- Block einfuegen mit Layergenerierung ----14.8.92 AW
; MIT DREHMOEGLICHKEIT !!!
(DEFUN c:sympl_dr ( / einp); / einp ebene symname)
(SETQ einp (GETPOINT "\nInsert-Point: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp "" "" pause)
)
;----------- Block einfuegen mit Layergenerierung ---16.9.93 AW
; MIT DREHMOEGLICHKEIT UND URSPRUNG NACH DEM SETZEN !!!
(DEFUN c:sympldr2 ( / einp drehung groesse)
(setq groesse "1")
(SETQ einp (GETPOINT "\nInsert-Point: "))
(SETQ drehung (GETSTRING "\nRotation: "))
(SETQ groesse (GETSTRING "\nScale: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp groesse groesse drehung)
(COMMAND "_explode" "_last")
)
;----------- Block einfuegen mit Layergenerierung ---21.11.93 AW
; ABFRAGE: SKALIERUNG/ DREHMOEGLICHKEIT UND URSPRUNG NACH DEM SETZEN !!!
(DEFUN c:sympldr1 ( / einp drehung)
(SETQ einp (GETPOINT "\nInsert-Point: "))
(SETQ drehung (GETSTRING "\nRotation: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp "" "" drehung)
(COMMAND "_explode" "_last")
)
;----------- Block einfuegen mit Layergenerierung und Skalierung ---12.2.93 AW
(DEFUN c:sym_scal ( / einp p1 p2); / einp ebene symname)
(SETQ einp (GETPOINT "\nInsert-Point: "))
(SETQ p1 (GETREAL "\nX-Scale: "))
(SETQ p2 (GETREAL "\nY-Scale: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp p1 p2 "0")
)
;------------ Farbe aendern - AUFRUF aus POP2--------------------------
(DEFUN c:alt_farb ( / sst_obj neuefarb)
(setq sst_obj (ssget) neuefarb (getstring "\nNew-Color: "))
(command "_change" sst_obj "" "_prop" "_co" neuefarb "")
)
;--------------------------------------------------------------------
(defun block-op (PT0 szoeg auswahl-satz / komponente1 komponente2
seconds element-name gefunden)
;------------------
; Block definieren
;-----------------------------------------------------------
; PT0 - Origin der Baugruppe
; szoeg - Einfuegewinkel
; auswahl-satz - Elemente des Blockes in Auswahlsatz
;------------------------------------------------------------
(setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
(itoa (abs (fix (caddr PT0))))))
(setq komponente2 szoeg)
(setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
(setq element-name (strcat komponente1 komponente2 seconds))
(princ)
(princ (strcat komponente1 "\n"))
(princ (strcat komponente2 "\n"))
(princ (strcat seconds "\n"))
(princ)
(princ (strcat "\n" element-name "\n"))
(princ)
(setq gefunden (tblsearch "block" element-name))
(if (not gefunden)
(progn
(princ)
(command "_block" element-name PT0 auswahl-satz "")
(command "_insert" element-name PT0 "" "" szoeg)
)
(progn
(alert (strcat "\nBlockname: " element-name " already exists." ))
(setq element-name (strcat "x" element-name))
(alert (strcat "\nCorrected blockname: " element-name " .OK!"))
(command "_block" element-name PT0 auswahl-satz "")
(command "_insert" element-name PT0 "" "" szoeg)
)
)
)
(defun bl-name (PT0 / komponente1 seconds)
; 14.4.94
; Verwendung bei Baugruppen, deren Bestandteile aufgelistet
; werden m�ssen.
; Name eines Blockes gleich am Anfang des Programmes festlegen
; - die Einzelkomponenten werden in "C" mit diesem Wert belegt
; - dadurch ist eine eindeutige Gruppenzugeh"rigkeit m"glich
;
(setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
(itoa (abs (fix (caddr PT0))))))
(setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
(setq block-kennung (strcat komponente1 seconds))
(princ)
)
(defun mach-block-ohne-prop (PT0 szoeg auswahl-satz / komponente1 komponente2
seconds element-name gefunden)
;------------------
; Block definieren
;-----------------------------------------------------------
; PT0 - Origin der Baugruppe
; szoeg - Einfuegewinkel
; auswahl-satz - Elemente des Blockes in Auswahlsatz
;------------------------------------------------------------
(setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
(itoa (abs (fix (caddr PT0))))))
(setq komponente2 szoeg)
(setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
(setq element-name (strcat komponente1 komponente2 seconds))
(princ)
(princ (strcat komponente1 "\n"))
(princ (strcat komponente2 "\n"))
(princ (strcat seconds "\n"))
(princ)
(princ (strcat "\n" element-name "\n"))
(princ)
(setq gefunden (tblsearch "block" element-name))
(if (not gefunden)
(progn
(princ)
(command "_block" element-name PT0 auswahl-satz "")
(command "_insert" element-name PT0 "" "" szoeg)
)
(alert "\nBlockname exists. You need HELP !")
)
)
(defun mach-block (PT0 szoeg auswahl-satz / komponente1 komponente2
seconds element-name gefunden)
;------------------
; Block definieren
;-----------------------------------------------------------
; PT0 - Origin der Baugruppe
; szoeg - Einfuegewinkel
; auswahl-satz - Elemente des Blockes in Auswahlsatz
;------------------------------------------------------------
(setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
(itoa (abs (fix (caddr PT0))))))
(setq komponente2 szoeg)
(setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
(setq element-name (strcat komponente1 komponente2 seconds))
(princ)
(princ (strcat komponente1 "\n"))
(princ (strcat komponente2 "\n"))
(princ (strcat seconds "\n"))
(princ)
(princ (strcat "\n" element-name "\n"))
(princ)
(setq gefunden (tblsearch "block" element-name))
(if (not gefunden)
(progn
(princ)
(command "_insert" (strcat "*" lw "/acadsst/menu/a") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/b") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/c") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/artinr") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/beschr") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/menge") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/position") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/gruppe") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/etikette") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/aufloese") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_block" element-name PT0 auswahl-satz "")
(command "_insert" element-name PT0 "" "" szoeg)
)
(alert "\nBlockname exists. You need HELP !")
)
)
;---------- Attribute aendern - Laenge,Endstueck,Artikel-Nr.--------------------
(defun ATTRIBUTE-AENDERN (M_POSITION M_ETIKETTE M_GRUPPE M_A M_B M_C M_ARTINR
M_BESCHR M_MENGE M_AUFLOESE / objekt typ
attribut-bezeichnung attribut-wert)
(setq objekt (entlast))
(while (not (equal
(cdr (assoc 0 (entget objekt)))
"SEQEND"))
(setq typ
(cdr (assoc 0 (entget objekt))))
(if
(equal typ "ATTRIB")
(progn
(setq ATTRIBUT-BEZEICHNUNG (cdr (assoc 2 (entget objekt))))
(setq ATTRIBUT-WERT (cdr (assoc 1 (entget objekt))))
(if (and (> (strlen M_POSITION) 0) (= ATTRIBUT-BEZEICHNUNG "POSITION"))
(entmod (subst (cons 1 M_POSITION) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_ETIKETTE) 0) (= ATTRIBUT-BEZEICHNUNG "ETIKETTE"))
(entmod (subst (cons 1 M_ETIKETTE) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_GRUPPE) 0) (= ATTRIBUT-BEZEICHNUNG "GRUPPE"))
(entmod (subst (cons 1 M_GRUPPE) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_A) 0) (equal ATTRIBUT-BEZEICHNUNG "A"))
(entmod (subst (cons 1 M_A) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_B) 0) (equal ATTRIBUT-BEZEICHNUNG "B"))
(entmod (subst (cons 1 M_B) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_C) 0) (equal ATTRIBUT-BEZEICHNUNG "C"))
(entmod (subst (cons 1 M_C) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_ARTINR) 0) (equal ATTRIBUT-BEZEICHNUNG "ARTINR"))
(entmod (subst (cons 1 M_ARTINR) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_BESCHR) 0) (equal ATTRIBUT-BEZEICHNUNG "BESCHR"))
(entmod (subst (cons 1 (strcat ATTRIBUT-WERT M_BESCHR))
(assoc 1 (entget objekt)) (entget objekt)))
)
(if (and (> (strlen M_MENGE) 0) (equal ATTRIBUT-BEZEICHNUNG "MENGE"))
(entmod (subst (cons 1 M_MENGE)
(assoc 1 (entget objekt)) (entget objekt)))
)
(if (and (> (strlen M_AUFLOESE) 0) (equal ATTRIBUT-BEZEICHNUNG "AUFLOESE"))
(entmod (subst (cons 1 M_AUFLOESE)
(assoc 1 (entget objekt)) (entget objekt)))
)
) ; Ende ----progn
) ; Ende ----if
(setq objekt (entnext objekt))
)
(setq objekt objekt)
)
;---------- Attribute aendern - Laenge,Endstueck,Artikel-Nr.--------------------
(defun ATTRIBUTE-AENDERN_IO (M_IO M_ID M_VERW M_BEZEICHNUNG M_KENNZEICHNUNG M_SPS / objekt typ attribut-bezeichnung attribut-wert)
(setq objekt (entlast))
(while (not (equal
(cdr (assoc 0 (entget objekt)))
"SEQEND"))
(setq typ
(cdr (assoc 0 (entget objekt))))
(if
(equal typ "ATTRIB")
(progn
(setq ATTRIBUT-BEZEICHNUNG (cdr (assoc 2 (entget objekt))))
(setq ATTRIBUT-WERT (cdr (assoc 1 (entget objekt))))
(if (and (> (strlen M_IO) 0) (= ATTRIBUT-BEZEICHNUNG "IO"))
(entmod (subst (cons 1 M_IO) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_ID) 0) (= ATTRIBUT-BEZEICHNUNG "ID"))
(entmod (subst (cons 1 M_ID) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_VERW) 0) (= ATTRIBUT-BEZEICHNUNG "VERW"))
(entmod (subst (cons 1 M_VERW) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_BEZEICHNUNG) 0) (= ATTRIBUT-BEZEICHNUNG "BEZEICHNUNG"))
(entmod (subst (cons 1 M_BEZEICHNUNG) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_KENNZEICHNUNG) 0) (= ATTRIBUT-BEZEICHNUNG "KENNZEICHNUNG"))
(entmod (subst (cons 1 M_KENNZEICHNUNG) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_SPS) 0) (= ATTRIBUT-BEZEICHNUNG "SPS"))
(entmod (subst (cons 1 M_SPS) (assoc 1 (entget objekt))
(entget objekt)))
)
) ; Ende ----progn
) ; Ende ----if
(setq objekt (entnext objekt))
)
(setq objekt objekt)
)
;--- Objekt in der DB suchen und Attribut "ndern ---------------
; Parameter:
; ref - handle
; bezeichnung - Attributbezeichnung, die gesucht ist
; wert - neuer Wert
; addition = 0 - Attributbezeichnung wird mit "wert" ersetzt
; 1 - Attributbezeichnung wird mit "wert" erg"nzt
;----------------------------------------------------------------
(defun suchen-aendern ( ref bezeichnung wert addition
/ typ attribut-bezeichnung attribut-wert)
(redraw (handent ref) 3)
(obj-suchen ref)
(redraw (handent ref))
)
(defun obj-suchen (ref)
(setq raus 0)
(setq e (entnext))
(while e
(setq typ (cdr (assoc 0 (entget e))))
(setq blockname (cdr (assoc 2 (entget e))))
(if
(and
(equal (cdr (assoc 5 (entget e))) ref)
(equal typ "INSERT")
(equal (cdr (assoc 66 (entget e))) 1)
)
(progn
(einzel-attr-aendern bezeichnung wert addition)
(setq raus 1) ; rausspringen !!!
)
)
(setq e (entnext e))
(if (= RAUS 1)
(setq e NIL)
)
)
)
(defun einzel-attr-aendern (BEZEICHNUNG WERT ADDITION)
(while (not (= (cdr (assoc 0 (entget e))) "SEQEND"))
(setq typ (cdr (assoc 0 (entget e))))
(if
(equal typ "ATTRIB")
(progn
(setq ATTRIBUT-BEZEICHNUNG (cdr (assoc 2 (entget e))))
(setq ATTRIBUT-WERT (cdr (assoc 1 (entget e))))
(if (= ADDITION 0) ; Attributwert GANZ ersetzen
(progn
(if (equal ATTRIBUT-BEZEICHNUNG BEZEICHNUNG)
(entmod (subst (cons 1 WERT)
(assoc 1 (entget e)) (entget e)))
)
)
)
(if (= ADDITION 1) ; Attributwert ERGAENZEN
(progn
(if (equal ATTRIBUT-BEZEICHNUNG BEZEICHNUNG)
(entmod (subst (cons 1 (strcat ATTRIBUT-WERT WERT))
(assoc 1 (entget e)) (entget e)))
)
)
)
) ; Ende ----progn
)
(setq e (entnext e))
)
)
;--------------------------------------------------------------------------
(setq lw "m:")
(setvar "attreq" 0)
(setq
v-lay (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10")
v-col (list "7" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10")
v-ltyp (list "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" )
)
;----------------------------------------------------------------------------
(prompt "\nSSG-Menu.. (c) 2013 by SCHÖNENBERGER Systeme GmbH - All rights reserved")
(prompt " ")
(princ)
doc/acadsst/MENU/ssg_110617.lsp
+515
View File
@@ -0,0 +1,515 @@
(IF SPECIAL
(SPECIAL '(olde ptest cavar bell prna))
(DEFUN SPECIAL (x) nil)
)
(DEFUN pstart (tit qust setv / xlen xpos xvar)
(SETQ olde *ERROR*
*ERROR* (IF ptest NIL errhan)
cavar (APPEND '(("CLAYER")("CMDECHO"))
setv)
xlen (LENGTH cavar)
xpos 0
)
(REPEAT xlen
(SETQ xvar (CAR (NTH xpos cavar))
cavar (SUBST (CONS xvar (GETVAR xvar))
(NTH xpos cavar) cavar)
xpos (1+ xpos)
)
)
(SETVAR "CMDECHO" 0)
(COMMAND "_undo" "_G")
(GRAPHSCR)
(PROMPT (STRCAT "\n***** " tit " *****\n\n " qust))
(PRINC)
)
(DEFUN pend (/ xpos xlen xvar)
(IF cavar
(PROGN
(COMMAND)
(COMMAND "_undo" "_E")
(SETQ xpos 1
xlen (LENGTH cavar)
)
(IF (/= (GETVAR "CLAYER") (CAAR cavar))
(COMMAND "_LAYER" "_SE" (CDAR CAVAR) "")
)
(REPEAT (1- xlen)
(SETQ xvar (NTH xpos cavar)
xpos (1+ xpos)
)
(SETVAR (CAR xvar)(CDR xvar))
)
)
)
(IF olde (SETQ *ERROR* olde))
(PRINC)
)
(DEFUN errhan (em)
(IF (= em "Function cancelled")
(PRINC)
(PRINC em)
)
(GRTEXT)
(COMMAND)
(COMMAND)
(pend)
)
(DEFUN ques (dial defa) ;Std Abfrage
(IF defa
(PROGN
(INITGET 1 "Yes No Yes")
(= (GETKWORD (STRCAT "\n" dial " Y/N <Y>: ")) "No")
)
(PROGN
(INITGET 1 "Yes No No")
(= (GETKWORD (STRCAT "\n" dial " Y/N <Y>: ")) "Yes")
)
)
)
(DEFUN emsg (etxt)
(IF (NOT bell)(PROMPT "\007"))
(TERPRI)
(PROMPT etxt)
(TERPRI)
)
(DEFUN ques (dial defa) ;Std Abfrage
(IF defa
(PROGN
(INITGET 1 "Yes No Yes")
(= (GETKWORD (STRCAT "\n" dial " Y/N <Y>: ")) "No")
)
(PROGN
(INITGET 1 "Yes No No")
(= (GETKWORD (STRCAT "\n" dial " Y/N <N>: ")) "Yes")
)
)
)
(DEFUN renv (envn prnn / penv)
(IF (SETQ penv (GETENV envn))
(EVAL (STRCAT penv "" prnn))
(EVAL prnn)
)
)
(DEFUN C:PRG (/ nprg cprg prna)
(SETQ nprg (GETSTRING)
cprg (STRCAT "C:" nprg)
prna (renv "ACADLSP" nprg)
)
(IF (NULL (EVAL (READ cprg)))
(PROGN
(PRINC " loading...!\n")
(COND
((FINDFILE (STRCAT prna ".BI4"))
(LOAD prna ".BI4"))
((FINDFILE (STRCAT prna ".BI2"))
(LOAD prna ".BI2"))
((FINDFILE (STRCAT prna ".LSP"))
(LOAD prna ".LSP"))
( T (emsg "File not found"))
)
)
)
(PRINC)
)
(DEFUN C:ed (/ prnn)
(IF (NULL prna)
(SETQ prna "")
)
(SETQ prnn (GETSTRING
(STRCAT "Programname <" prna ">: ")))
(IF (AND (= (STRLEN prna) 0)(= (STRLEN prnn) 0))
(emsg "Name not allowed...")
(PROGN
(IF (> (STRLEN prnn) 0)
(SETQ prna (renv "ACADLSP" prnn))
)
(COMMAND "SHELL" (STRCAT "ED " prna ))
(INITGET 1 "Yes No Yes")
(IF (NOT (ques "Load the program" T))
(LOAD prna)
)
)
)
(PRINC)
)
;----------- Block einfuegen mit Layergenerierung ----2.8.92 AW
; KEINE DREHMOEGLICHKEIT !!!
(DEFUN c:symplac ( / einp); / einp ebene symname)
(SETQ einp (GETPOINT "\nInsert-Point: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp "" "" "0")
)
;----------- Block einfuegen mit Layergenerierung ----14.8.92 AW
; MIT DREHMOEGLICHKEIT !!!
(DEFUN c:sympl_dr ( / einp); / einp ebene symname)
(SETQ einp (GETPOINT "\nInsert-Point: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp "" "" pause)
)
;----------- Block einfuegen mit Layergenerierung ---16.9.93 AW
; MIT DREHMOEGLICHKEIT UND URSPRUNG NACH DEM SETZEN !!!
(DEFUN c:sympldr2 ( / einp drehung groesse)
(setq groesse "1")
(SETQ einp (GETPOINT "\nInsert-Point: "))
(SETQ drehung (GETSTRING "\nRotation: "))
(SETQ groesse (GETSTRING "\nScale: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp groesse groesse drehung)
(COMMAND "_explode" "_last")
)
;----------- Block einfuegen mit Layergenerierung ---21.11.93 AW
; ABFRAGE: SKALIERUNG/ DREHMOEGLICHKEIT UND URSPRUNG NACH DEM SETZEN !!!
(DEFUN c:sympldr1 ( / einp drehung)
(SETQ einp (GETPOINT "\nInsert-Point: "))
(SETQ drehung (GETSTRING "\nRotation: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp "" "" drehung)
(COMMAND "_explode" "_last")
)
;----------- Block einfuegen mit Layergenerierung und Skalierung ---12.2.93 AW
(DEFUN c:sym_scal ( / einp p1 p2); / einp ebene symname)
(SETQ einp (GETPOINT "\nInsert-Point: "))
(SETQ p1 (GETREAL "\nX-Scale: "))
(SETQ p2 (GETREAL "\nY-Scale: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp p1 p2 "0")
)
;------------ Farbe aendern - AUFRUF aus POP2--------------------------
(DEFUN c:alt_farb ( / sst_obj neuefarb)
(setq sst_obj (ssget) neuefarb (getstring "\nNew-Color: "))
(command "_change" sst_obj "" "_prop" "_co" neuefarb "")
)
;--------------------------------------------------------------------
(defun block-op (PT0 szoeg auswahl-satz / komponente1 komponente2
seconds element-name gefunden)
;------------------
; Block definieren
;-----------------------------------------------------------
; PT0 - Origin der Baugruppe
; szoeg - Einfuegewinkel
; auswahl-satz - Elemente des Blockes in Auswahlsatz
;------------------------------------------------------------
(setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
(itoa (abs (fix (caddr PT0))))))
(setq komponente2 szoeg)
(setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
(setq element-name (strcat komponente1 komponente2 seconds))
(princ)
(princ (strcat komponente1 "\n"))
(princ (strcat komponente2 "\n"))
(princ (strcat seconds "\n"))
(princ)
(princ (strcat "\n" element-name "\n"))
(princ)
(setq gefunden (tblsearch "block" element-name))
(if (not gefunden)
(progn
(princ)
(command "_block" element-name PT0 auswahl-satz "")
(command "_insert" element-name PT0 "" "" szoeg)
)
(progn
(alert (strcat "\nBlockname: " element-name " already exists." ))
(setq element-name (strcat "x" element-name))
(alert (strcat "\nCorrected blockname: " element-name " .OK!"))
(command "_block" element-name PT0 auswahl-satz "")
(command "_insert" element-name PT0 "" "" szoeg)
)
)
)
(defun bl-name (PT0 / komponente1 seconds)
; 14.4.94
; Verwendung bei Baugruppen, deren Bestandteile aufgelistet
; werden m�ssen.
; Name eines Blockes gleich am Anfang des Programmes festlegen
; - die Einzelkomponenten werden in "C" mit diesem Wert belegt
; - dadurch ist eine eindeutige Gruppenzugeh"rigkeit m"glich
;
(setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
(itoa (abs (fix (caddr PT0))))))
(setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
(setq block-kennung (strcat komponente1 seconds))
(princ)
)
(defun mach-block-ohne-prop (PT0 szoeg auswahl-satz / komponente1 komponente2
seconds element-name gefunden)
;------------------
; Block definieren
;-----------------------------------------------------------
; PT0 - Origin der Baugruppe
; szoeg - Einfuegewinkel
; auswahl-satz - Elemente des Blockes in Auswahlsatz
;------------------------------------------------------------
(setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
(itoa (abs (fix (caddr PT0))))))
(setq komponente2 szoeg)
(setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
(setq element-name (strcat komponente1 komponente2 seconds))
(princ)
(princ (strcat komponente1 "\n"))
(princ (strcat komponente2 "\n"))
(princ (strcat seconds "\n"))
(princ)
(princ (strcat "\n" element-name "\n"))
(princ)
(setq gefunden (tblsearch "block" element-name))
(if (not gefunden)
(progn
(princ)
(command "_block" element-name PT0 auswahl-satz "")
(command "_insert" element-name PT0 "" "" szoeg)
)
(alert "\nBlockname exists. You need HELP !")
)
)
(defun mach-block (PT0 szoeg auswahl-satz / komponente1 komponente2
seconds element-name gefunden)
;------------------
; Block definieren
;-----------------------------------------------------------
; PT0 - Origin der Baugruppe
; szoeg - Einfuegewinkel
; auswahl-satz - Elemente des Blockes in Auswahlsatz
;------------------------------------------------------------
(setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
(itoa (abs (fix (caddr PT0))))))
(setq komponente2 szoeg)
(setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
(setq element-name (strcat komponente1 komponente2 seconds))
(princ)
(princ (strcat komponente1 "\n"))
(princ (strcat komponente2 "\n"))
(princ (strcat seconds "\n"))
(princ)
(princ (strcat "\n" element-name "\n"))
(princ)
(setq gefunden (tblsearch "block" element-name))
(if (not gefunden)
(progn
(princ)
(command "_insert" (strcat "*" lw "/acadsst/menu/a") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/b") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/c") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/artinr") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/beschr") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/menge") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/position") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/gruppe") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/etikette") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/aufloese") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_block" element-name PT0 auswahl-satz "")
(command "_insert" element-name PT0 "" "" szoeg)
)
(alert "\nBlockname exists. You need HELP !")
)
)
;---------- Attribute aendern - Laenge,Endstueck,Artikel-Nr.--------------------
(defun ATTRIBUTE-AENDERN (M_POSITION M_ETIKETTE M_GRUPPE M_A M_B M_C M_ARTINR
M_BESCHR M_MENGE M_AUFLOESE / objekt typ
attribut-bezeichnung attribut-wert)
(setq objekt (entlast))
(while (not (equal
(cdr (assoc 0 (entget objekt)))
"SEQEND"))
(setq typ
(cdr (assoc 0 (entget objekt))))
(if
(equal typ "ATTRIB")
(progn
(setq ATTRIBUT-BEZEICHNUNG (cdr (assoc 2 (entget objekt))))
(setq ATTRIBUT-WERT (cdr (assoc 1 (entget objekt))))
(if (and (> (strlen M_POSITION) 0) (= ATTRIBUT-BEZEICHNUNG "POSITION"))
(entmod (subst (cons 1 M_POSITION) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_ETIKETTE) 0) (= ATTRIBUT-BEZEICHNUNG "ETIKETTE"))
(entmod (subst (cons 1 M_ETIKETTE) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_GRUPPE) 0) (= ATTRIBUT-BEZEICHNUNG "GRUPPE"))
(entmod (subst (cons 1 M_GRUPPE) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_A) 0) (equal ATTRIBUT-BEZEICHNUNG "A"))
(entmod (subst (cons 1 M_A) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_B) 0) (equal ATTRIBUT-BEZEICHNUNG "B"))
(entmod (subst (cons 1 M_B) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_C) 0) (equal ATTRIBUT-BEZEICHNUNG "C"))
(entmod (subst (cons 1 M_C) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_ARTINR) 0) (equal ATTRIBUT-BEZEICHNUNG "ARTINR"))
(entmod (subst (cons 1 M_ARTINR) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_BESCHR) 0) (equal ATTRIBUT-BEZEICHNUNG "BESCHR"))
(entmod (subst (cons 1 (strcat ATTRIBUT-WERT M_BESCHR))
(assoc 1 (entget objekt)) (entget objekt)))
)
(if (and (> (strlen M_MENGE) 0) (equal ATTRIBUT-BEZEICHNUNG "MENGE"))
(entmod (subst (cons 1 M_MENGE)
(assoc 1 (entget objekt)) (entget objekt)))
)
(if (and (> (strlen M_AUFLOESE) 0) (equal ATTRIBUT-BEZEICHNUNG "AUFLOESE"))
(entmod (subst (cons 1 M_AUFLOESE)
(assoc 1 (entget objekt)) (entget objekt)))
)
) ; Ende ----progn
) ; Ende ----if
(setq objekt (entnext objekt))
)
(setq objekt objekt)
)
;---------- Attribute aendern - Laenge,Endstueck,Artikel-Nr.--------------------
(defun ATTRIBUTE-AENDERN_IO (M_IO M_ID M_VERW M_BEZEICHNUNG M_KENNZEICHNUNG / objekt typ attribut-bezeichnung attribut-wert)
(setq objekt (entlast))
(while (not (equal
(cdr (assoc 0 (entget objekt)))
"SEQEND"))
(setq typ
(cdr (assoc 0 (entget objekt))))
(if
(equal typ "ATTRIB")
(progn
(setq ATTRIBUT-BEZEICHNUNG (cdr (assoc 2 (entget objekt))))
(setq ATTRIBUT-WERT (cdr (assoc 1 (entget objekt))))
(if (and (> (strlen M_IO) 0) (= ATTRIBUT-BEZEICHNUNG "IO"))
(entmod (subst (cons 1 M_IO) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_ID) 0) (= ATTRIBUT-BEZEICHNUNG "ID"))
(entmod (subst (cons 1 M_ID) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_VERW) 0) (= ATTRIBUT-BEZEICHNUNG "VERW"))
(entmod (subst (cons 1 M_VERW) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_BEZEICHNUNG) 0) (= ATTRIBUT-BEZEICHNUNG "BEZEICHNUNG"))
(entmod (subst (cons 1 M_BEZEICHNUNG) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_KENNZEICHNUNG) 0) (= ATTRIBUT-BEZEICHNUNG "KENNZEICHNUNG"))
(entmod (subst (cons 1 M_KENNZEICHNUNG) (assoc 1 (entget objekt))
(entget objekt)))
)
) ; Ende ----progn
) ; Ende ----if
(setq objekt (entnext objekt))
)
(setq objekt objekt)
)
;--- Objekt in der DB suchen und Attribut "ndern ---------------
; Parameter:
; ref - handle
; bezeichnung - Attributbezeichnung, die gesucht ist
; wert - neuer Wert
; addition = 0 - Attributbezeichnung wird mit "wert" ersetzt
; 1 - Attributbezeichnung wird mit "wert" erg"nzt
;----------------------------------------------------------------
(defun suchen-aendern ( ref bezeichnung wert addition
/ typ attribut-bezeichnung attribut-wert)
(redraw (handent ref) 3)
(obj-suchen ref)
(redraw (handent ref))
)
(defun obj-suchen (ref)
(setq raus 0)
(setq e (entnext))
(while e
(setq typ (cdr (assoc 0 (entget e))))
(setq blockname (cdr (assoc 2 (entget e))))
(if
(and
(equal (cdr (assoc 5 (entget e))) ref)
(equal typ "INSERT")
(equal (cdr (assoc 66 (entget e))) 1)
)
(progn
(einzel-attr-aendern bezeichnung wert addition)
(setq raus 1) ; rausspringen !!!
)
)
(setq e (entnext e))
(if (= RAUS 1)
(setq e NIL)
)
)
)
(defun einzel-attr-aendern (BEZEICHNUNG WERT ADDITION)
(while (not (= (cdr (assoc 0 (entget e))) "SEQEND"))
(setq typ (cdr (assoc 0 (entget e))))
(if
(equal typ "ATTRIB")
(progn
(setq ATTRIBUT-BEZEICHNUNG (cdr (assoc 2 (entget e))))
(setq ATTRIBUT-WERT (cdr (assoc 1 (entget e))))
(if (= ADDITION 0) ; Attributwert GANZ ersetzen
(progn
(if (equal ATTRIBUT-BEZEICHNUNG BEZEICHNUNG)
(entmod (subst (cons 1 WERT)
(assoc 1 (entget e)) (entget e)))
)
)
)
(if (= ADDITION 1) ; Attributwert ERGAENZEN
(progn
(if (equal ATTRIBUT-BEZEICHNUNG BEZEICHNUNG)
(entmod (subst (cons 1 (strcat ATTRIBUT-WERT WERT))
(assoc 1 (entget e)) (entget e)))
)
)
)
) ; Ende ----progn
)
(setq e (entnext e))
)
)
;--------------------------------------------------------------------------
(setq lw "m:")
(setvar "attreq" 0)
(setq
v-lay (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10")
v-col (list "7" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10")
v-ltyp (list "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" )
)
;----------------------------------------------------------------------------
(prompt "\nSSG-Menu.. (c) 2007 by SCHÖNENBERGER Systeme GmbH - All rights reserved")
(prompt " ")
(princ)
doc/acadsst/MENU/ssg_130829.lsp
+518
View File
@@ -0,0 +1,518 @@
(IF SPECIAL
(SPECIAL '(olde ptest cavar bell prna))
(DEFUN SPECIAL (x) nil)
)
(DEFUN pstart (tit qust setv / xlen xpos xvar)
(SETQ olde *ERROR*
*ERROR* (IF ptest NIL errhan)
cavar (APPEND '(("CLAYER")("CMDECHO"))
setv)
xlen (LENGTH cavar)
xpos 0
)
(REPEAT xlen
(SETQ xvar (CAR (NTH xpos cavar))
cavar (SUBST (CONS xvar (GETVAR xvar))
(NTH xpos cavar) cavar)
xpos (1+ xpos)
)
)
(SETVAR "CMDECHO" 0)
(COMMAND "_undo" "_G")
(GRAPHSCR)
(PROMPT (STRCAT "\n***** " tit " *****\n\n " qust))
(PRINC)
)
(DEFUN pend (/ xpos xlen xvar)
(IF cavar
(PROGN
(COMMAND)
(COMMAND "_undo" "_E")
(SETQ xpos 1
xlen (LENGTH cavar)
)
(IF (/= (GETVAR "CLAYER") (CAAR cavar))
(COMMAND "_LAYER" "_SE" (CDAR CAVAR) "")
)
(REPEAT (1- xlen)
(SETQ xvar (NTH xpos cavar)
xpos (1+ xpos)
)
(SETVAR (CAR xvar)(CDR xvar))
)
)
)
(IF olde (SETQ *ERROR* olde))
(PRINC)
)
(DEFUN errhan (em)
(IF (= em "Function cancelled")
(PRINC)
(PRINC em)
)
(GRTEXT)
(COMMAND)
(COMMAND)
(pend)
)
(DEFUN ques (dial defa) ;Std Abfrage
(IF defa
(PROGN
(INITGET 1 "Yes No Yes")
(= (GETKWORD (STRCAT "\n" dial " Y/N <Y>: ")) "No")
)
(PROGN
(INITGET 1 "Yes No No")
(= (GETKWORD (STRCAT "\n" dial " Y/N <Y>: ")) "Yes")
)
)
)
(DEFUN emsg (etxt)
(IF (NOT bell)(PROMPT "\007"))
(TERPRI)
(PROMPT etxt)
(TERPRI)
)
(DEFUN ques (dial defa) ;Std Abfrage
(IF defa
(PROGN
(INITGET 1 "Yes No Yes")
(= (GETKWORD (STRCAT "\n" dial " Y/N <Y>: ")) "No")
)
(PROGN
(INITGET 1 "Yes No No")
(= (GETKWORD (STRCAT "\n" dial " Y/N <N>: ")) "Yes")
)
)
)
(DEFUN renv (envn prnn / penv)
(IF (SETQ penv (GETENV envn))
(EVAL (STRCAT penv "" prnn))
(EVAL prnn)
)
)
(DEFUN C:PRG (/ nprg cprg prna)
(SETQ nprg (GETSTRING)
cprg (STRCAT "C:" nprg)
prna (renv "ACADLSP" nprg)
)
(IF (NULL (EVAL (READ cprg)))
(PROGN
(PRINC " loading...!\n")
(COND
((FINDFILE (STRCAT prna ".BI4"))
(LOAD prna ".BI4"))
((FINDFILE (STRCAT prna ".BI2"))
(LOAD prna ".BI2"))
((FINDFILE (STRCAT prna ".LSP"))
(LOAD prna ".LSP"))
( T (emsg "File not found"))
)
)
)
(PRINC)
)
(DEFUN C:ed (/ prnn)
(IF (NULL prna)
(SETQ prna "")
)
(SETQ prnn (GETSTRING
(STRCAT "Programname <" prna ">: ")))
(IF (AND (= (STRLEN prna) 0)(= (STRLEN prnn) 0))
(emsg "Name not allowed...")
(PROGN
(IF (> (STRLEN prnn) 0)
(SETQ prna (renv "ACADLSP" prnn))
)
(COMMAND "SHELL" (STRCAT "ED " prna ))
(INITGET 1 "Yes No Yes")
(IF (NOT (ques "Load the program" T))
(LOAD prna)
)
)
)
(PRINC)
)
;----------- Block einfuegen mit Layergenerierung ----2.8.92 AW
; KEINE DREHMOEGLICHKEIT !!!
(DEFUN c:symplac ( / einp); / einp ebene symname)
(SETQ einp (GETPOINT "\nInsert-Point: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp "" "" "0")
)
;----------- Block einfuegen mit Layergenerierung ----14.8.92 AW
; MIT DREHMOEGLICHKEIT !!!
(DEFUN c:sympl_dr ( / einp); / einp ebene symname)
(SETQ einp (GETPOINT "\nInsert-Point: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp "" "" pause)
)
;----------- Block einfuegen mit Layergenerierung ---16.9.93 AW
; MIT DREHMOEGLICHKEIT UND URSPRUNG NACH DEM SETZEN !!!
(DEFUN c:sympldr2 ( / einp drehung groesse)
(setq groesse "1")
(SETQ einp (GETPOINT "\nInsert-Point: "))
(SETQ drehung (GETSTRING "\nRotation: "))
(SETQ groesse (GETSTRING "\nScale: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp groesse groesse drehung)
(COMMAND "_explode" "_last")
)
;----------- Block einfuegen mit Layergenerierung ---21.11.93 AW
; ABFRAGE: SKALIERUNG/ DREHMOEGLICHKEIT UND URSPRUNG NACH DEM SETZEN !!!
(DEFUN c:sympldr1 ( / einp drehung)
(SETQ einp (GETPOINT "\nInsert-Point: "))
(SETQ drehung (GETSTRING "\nRotation: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp "" "" drehung)
(COMMAND "_explode" "_last")
)
;----------- Block einfuegen mit Layergenerierung und Skalierung ---12.2.93 AW
(DEFUN c:sym_scal ( / einp p1 p2); / einp ebene symname)
(SETQ einp (GETPOINT "\nInsert-Point: "))
(SETQ p1 (GETREAL "\nX-Scale: "))
(SETQ p2 (GETREAL "\nY-Scale: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp p1 p2 "0")
)
;------------ Farbe aendern - AUFRUF aus POP2--------------------------
(DEFUN c:alt_farb ( / sst_obj neuefarb)
(setq sst_obj (ssget) neuefarb (getstring "\nNew-Color: "))
(command "_change" sst_obj "" "_prop" "_co" neuefarb "")
)
;--------------------------------------------------------------------
(defun block-op (PT0 szoeg auswahl-satz / komponente1 komponente2
seconds element-name gefunden)
;------------------
; Block definieren
;-----------------------------------------------------------
; PT0 - Origin der Baugruppe
; szoeg - Einfuegewinkel
; auswahl-satz - Elemente des Blockes in Auswahlsatz
;------------------------------------------------------------
(setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
(itoa (abs (fix (caddr PT0))))))
(setq komponente2 szoeg)
(setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
(setq element-name (strcat komponente1 komponente2 seconds))
(princ)
(princ (strcat komponente1 "\n"))
(princ (strcat komponente2 "\n"))
(princ (strcat seconds "\n"))
(princ)
(princ (strcat "\n" element-name "\n"))
(princ)
(setq gefunden (tblsearch "block" element-name))
(if (not gefunden)
(progn
(princ)
(command "_block" element-name PT0 auswahl-satz "")
(command "_insert" element-name PT0 "" "" szoeg)
)
(progn
(alert (strcat "\nBlockname: " element-name " already exists." ))
(setq element-name (strcat "x" element-name))
(alert (strcat "\nCorrected blockname: " element-name " .OK!"))
(command "_block" element-name PT0 auswahl-satz "")
(command "_insert" element-name PT0 "" "" szoeg)
)
)
)
(defun bl-name (PT0 / komponente1 seconds)
; 14.4.94
; Verwendung bei Baugruppen, deren Bestandteile aufgelistet
; werden m�ssen.
; Name eines Blockes gleich am Anfang des Programmes festlegen
; - die Einzelkomponenten werden in "C" mit diesem Wert belegt
; - dadurch ist eine eindeutige Gruppenzugeh"rigkeit m"glich
;
(setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
(itoa (abs (fix (caddr PT0))))))
(setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
(setq block-kennung (strcat komponente1 seconds))
(princ)
)
(defun mach-block-ohne-prop (PT0 szoeg auswahl-satz / komponente1 komponente2
seconds element-name gefunden)
;------------------
; Block definieren
;-----------------------------------------------------------
; PT0 - Origin der Baugruppe
; szoeg - Einfuegewinkel
; auswahl-satz - Elemente des Blockes in Auswahlsatz
;------------------------------------------------------------
(setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
(itoa (abs (fix (caddr PT0))))))
(setq komponente2 szoeg)
(setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
(setq element-name (strcat komponente1 komponente2 seconds))
(princ)
(princ (strcat komponente1 "\n"))
(princ (strcat komponente2 "\n"))
(princ (strcat seconds "\n"))
(princ)
(princ (strcat "\n" element-name "\n"))
(princ)
(setq gefunden (tblsearch "block" element-name))
(if (not gefunden)
(progn
(princ)
(command "_block" element-name PT0 auswahl-satz "")
(command "_insert" element-name PT0 "" "" szoeg)
)
(alert "\nBlockname exists. You need HELP !")
)
)
(defun mach-block (PT0 szoeg auswahl-satz / komponente1 komponente2
seconds element-name gefunden)
;------------------
; Block definieren
;-----------------------------------------------------------
; PT0 - Origin der Baugruppe
; szoeg - Einfuegewinkel
; auswahl-satz - Elemente des Blockes in Auswahlsatz
;------------------------------------------------------------
(setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
(itoa (abs (fix (caddr PT0))))))
(setq komponente2 szoeg)
(setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
(setq element-name (strcat komponente1 komponente2 seconds))
(princ)
(princ (strcat komponente1 "\n"))
(princ (strcat komponente2 "\n"))
(princ (strcat seconds "\n"))
(princ)
(princ (strcat "\n" element-name "\n"))
(princ)
(setq gefunden (tblsearch "block" element-name))
(if (not gefunden)
(progn
(princ)
(command "_insert" (strcat "*" lw "/acadsst/menu/a") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/b") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/c") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/artinr") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/beschr") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/menge") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/position") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/gruppe") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/etikette") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/aufloese") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_block" element-name PT0 auswahl-satz "")
(command "_insert" element-name PT0 "" "" szoeg)
)
(alert "\nBlockname exists. You need HELP !")
)
)
;---------- Attribute aendern - Laenge,Endstueck,Artikel-Nr.--------------------
(defun ATTRIBUTE-AENDERN (M_POSITION M_ETIKETTE M_GRUPPE M_A M_B M_C M_ARTINR
M_BESCHR M_MENGE M_AUFLOESE / objekt typ
attribut-bezeichnung attribut-wert)
(setq objekt (entlast))
(while (not (equal
(cdr (assoc 0 (entget objekt)))
"SEQEND"))
(setq typ
(cdr (assoc 0 (entget objekt))))
(if
(equal typ "ATTRIB")
(progn
(setq ATTRIBUT-BEZEICHNUNG (cdr (assoc 2 (entget objekt))))
(setq ATTRIBUT-WERT (cdr (assoc 1 (entget objekt))))
(if (and (> (strlen M_POSITION) 0) (= ATTRIBUT-BEZEICHNUNG "POSITION"))
(entmod (subst (cons 1 M_POSITION) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_ETIKETTE) 0) (= ATTRIBUT-BEZEICHNUNG "ETIKETTE"))
(entmod (subst (cons 1 M_ETIKETTE) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_GRUPPE) 0) (= ATTRIBUT-BEZEICHNUNG "GRUPPE"))
(entmod (subst (cons 1 M_GRUPPE) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_A) 0) (equal ATTRIBUT-BEZEICHNUNG "A"))
(entmod (subst (cons 1 M_A) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_B) 0) (equal ATTRIBUT-BEZEICHNUNG "B"))
(entmod (subst (cons 1 M_B) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_C) 0) (equal ATTRIBUT-BEZEICHNUNG "C"))
(entmod (subst (cons 1 M_C) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_ARTINR) 0) (equal ATTRIBUT-BEZEICHNUNG "ARTINR"))
(entmod (subst (cons 1 M_ARTINR) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_BESCHR) 0) (equal ATTRIBUT-BEZEICHNUNG "BESCHR"))
(entmod (subst (cons 1 (strcat ATTRIBUT-WERT M_BESCHR))
(assoc 1 (entget objekt)) (entget objekt)))
)
(if (and (> (strlen M_MENGE) 0) (equal ATTRIBUT-BEZEICHNUNG "MENGE"))
(entmod (subst (cons 1 M_MENGE)
(assoc 1 (entget objekt)) (entget objekt)))
)
(if (and (> (strlen M_AUFLOESE) 0) (equal ATTRIBUT-BEZEICHNUNG "AUFLOESE"))
(entmod (subst (cons 1 M_AUFLOESE)
(assoc 1 (entget objekt)) (entget objekt)))
)
) ; Ende ----progn
) ; Ende ----if
(setq objekt (entnext objekt))
)
(setq objekt objekt)
)
;---------- Attribute aendern - Laenge,Endstueck,Artikel-Nr.--------------------
(defun ATTRIBUTE-AENDERN_IO (M_IO M_ID M_VERW M_BEZEICHNUNG M_KENNZEICHNUNG M_SPS / objekt typ attribut-bezeichnung attribut-wert)
(setq objekt (entlast))
(while (not (equal
(cdr (assoc 0 (entget objekt)))
"SEQEND"))
(setq typ
(cdr (assoc 0 (entget objekt))))
(if
(equal typ "ATTRIB")
(progn
(setq ATTRIBUT-BEZEICHNUNG (cdr (assoc 2 (entget objekt))))
(setq ATTRIBUT-WERT (cdr (assoc 1 (entget objekt))))
(if (and (> (strlen M_IO) 0) (= ATTRIBUT-BEZEICHNUNG "IO"))
(entmod (subst (cons 1 M_IO) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_ID) 0) (= ATTRIBUT-BEZEICHNUNG "ID"))
(entmod (subst (cons 1 M_ID) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_VERW) 0) (= ATTRIBUT-BEZEICHNUNG "VERW"))
(entmod (subst (cons 1 M_VERW) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_BEZEICHNUNG) 0) (= ATTRIBUT-BEZEICHNUNG "BEZEICHNUNG"))
(entmod (subst (cons 1 M_BEZEICHNUNG) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_KENNZEICHNUNG) 0) (= ATTRIBUT-BEZEICHNUNG "KENNZEICHNUNG"))
(entmod (subst (cons 1 M_KENNZEICHNUNG) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_SPS) 0) (= ATTRIBUT-BEZEICHNUNG "SPS"))
(entmod (subst (cons 1 M_SPS) (assoc 1 (entget objekt))
(entget objekt)))
)
) ; Ende ----progn
) ; Ende ----if
(setq objekt (entnext objekt))
)
(setq objekt objekt)
)
;--- Objekt in der DB suchen und Attribut "ndern ---------------
; Parameter:
; ref - handle
; bezeichnung - Attributbezeichnung, die gesucht ist
; wert - neuer Wert
; addition = 0 - Attributbezeichnung wird mit "wert" ersetzt
; 1 - Attributbezeichnung wird mit "wert" erg"nzt
;----------------------------------------------------------------
(defun suchen-aendern ( ref bezeichnung wert addition
/ typ attribut-bezeichnung attribut-wert)
(redraw (handent ref) 3)
(obj-suchen ref)
(redraw (handent ref))
)
(defun obj-suchen (ref)
(setq raus 0)
(setq e (entnext))
(while e
(setq typ (cdr (assoc 0 (entget e))))
(setq blockname (cdr (assoc 2 (entget e))))
(if
(and
(equal (cdr (assoc 5 (entget e))) ref)
(equal typ "INSERT")
(equal (cdr (assoc 66 (entget e))) 1)
)
(progn
(einzel-attr-aendern bezeichnung wert addition)
(setq raus 1) ; rausspringen !!!
)
)
(setq e (entnext e))
(if (= RAUS 1)
(setq e NIL)
)
)
)
(defun einzel-attr-aendern (BEZEICHNUNG WERT ADDITION)
(while (not (= (cdr (assoc 0 (entget e))) "SEQEND"))
(setq typ (cdr (assoc 0 (entget e))))
(if
(equal typ "ATTRIB")
(progn
(setq ATTRIBUT-BEZEICHNUNG (cdr (assoc 2 (entget e))))
(setq ATTRIBUT-WERT (cdr (assoc 1 (entget e))))
(if (= ADDITION 0) ; Attributwert GANZ ersetzen
(progn
(if (equal ATTRIBUT-BEZEICHNUNG BEZEICHNUNG)
(entmod (subst (cons 1 WERT)
(assoc 1 (entget e)) (entget e)))
)
)
)
(if (= ADDITION 1) ; Attributwert ERGAENZEN
(progn
(if (equal ATTRIBUT-BEZEICHNUNG BEZEICHNUNG)
(entmod (subst (cons 1 (strcat ATTRIBUT-WERT WERT))
(assoc 1 (entget e)) (entget e)))
)
)
)
) ; Ende ----progn
)
(setq e (entnext e))
)
)
;--------------------------------------------------------------------------
(setq lw "D:")
(setvar "attreq" 0)
(setq
v-lay (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10")
v-col (list "7" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10")
v-ltyp (list "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" )
)
;----------------------------------------------------------------------------
(prompt "\nSSG-Menu.. (c) 2011 by SCHÖNENBERGER Systeme GmbH - All rights reserved")
(prompt " ")
(princ)
doc/acadsst/MENU/ssg_old.lsp
+434
View File
@@ -0,0 +1,434 @@
(IF SPECIAL
(SPECIAL '(olde ptest cavar bell prna))
(DEFUN SPECIAL (x) nil)
)
(DEFUN pstart (tit qust setv / xlen xpos xvar)
(SETQ olde *ERROR*
*ERROR* (IF ptest NIL errhan)
cavar (APPEND '(("CLAYER")("CMDECHO"))
setv)
xlen (LENGTH cavar)
xpos 0
)
(REPEAT xlen
(SETQ xvar (CAR (NTH xpos cavar))
cavar (SUBST (CONS xvar (GETVAR xvar))
(NTH xpos cavar) cavar)
xpos (1+ xpos)
)
)
(SETVAR "CMDECHO" 0)
(COMMAND "_undo" "_G")
(GRAPHSCR)
(PROMPT (STRCAT "\n***** " tit " *****\n\n " qust))
(PRINC)
)
(DEFUN pend (/ xpos xlen xvar)
(IF cavar
(PROGN
(COMMAND)
(COMMAND "_undo" "_E")
(SETQ xpos 1
xlen (LENGTH cavar)
)
(IF (/= (GETVAR "CLAYER") (CAAR cavar))
(COMMAND "_LAYER" "_SE" (CDAR CAVAR) "")
)
(REPEAT (1- xlen)
(SETQ xvar (NTH xpos cavar)
xpos (1+ xpos)
)
(SETVAR (CAR xvar)(CDR xvar))
)
)
)
(IF olde (SETQ *ERROR* olde))
(PRINC)
)
(DEFUN errhan (em)
(IF (= em "Function cancelled")
(PRINC)
(PRINC em)
)
(GRTEXT)
(COMMAND)
(COMMAND)
(pend)
)
(DEFUN ques (dial defa) ;Std Abfrage
(IF defa
(PROGN
(INITGET 1 "Yes No Yes")
(= (GETKWORD (STRCAT "\n" dial " Y/N <Y>: ")) "No")
)
(PROGN
(INITGET 1 "Yes No No")
(= (GETKWORD (STRCAT "\n" dial " Y/N <Y>: ")) "Yes")
)
)
)
(DEFUN emsg (etxt)
(IF (NOT bell)(PROMPT "\007"))
(TERPRI)
(PROMPT etxt)
(TERPRI)
)
(DEFUN ques (dial defa) ;Std Abfrage
(IF defa
(PROGN
(INITGET 1 "Yes No Yes")
(= (GETKWORD (STRCAT "\n" dial " Y/N <Y>: ")) "No")
)
(PROGN
(INITGET 1 "Yes No No")
(= (GETKWORD (STRCAT "\n" dial " Y/N <N>: ")) "Yes")
)
)
)
(DEFUN renv (envn prnn / penv)
(IF (SETQ penv (GETENV envn))
(EVAL (STRCAT penv "" prnn))
(EVAL prnn)
)
)
(DEFUN C:PRG (/ nprg cprg prna)
(SETQ nprg (GETSTRING)
cprg (STRCAT "C:" nprg)
prna (renv "ACADLSP" nprg)
)
(IF (NULL (EVAL (READ cprg)))
(PROGN
(PRINC " loading...!\n")
(COND
((FINDFILE (STRCAT prna ".BI4"))
(LOAD prna ".BI4"))
((FINDFILE (STRCAT prna ".BI2"))
(LOAD prna ".BI2"))
((FINDFILE (STRCAT prna ".LSP"))
(LOAD prna ".LSP"))
( T (emsg "File not found"))
)
)
)
(PRINC)
)
(DEFUN C:ed (/ prnn)
(IF (NULL prna)
(SETQ prna "")
)
(SETQ prnn (GETSTRING
(STRCAT "Programname <" prna ">: ")))
(IF (AND (= (STRLEN prna) 0)(= (STRLEN prnn) 0))
(emsg "Name not allowed...")
(PROGN
(IF (> (STRLEN prnn) 0)
(SETQ prna (renv "ACADLSP" prnn))
)
(COMMAND "SHELL" (STRCAT "ED " prna ))
(INITGET 1 "Yes No Yes")
(IF (NOT (ques "Load the program" T))
(LOAD prna)
)
)
)
(PRINC)
)
;----------- Block einfuegen mit Layergenerierung ----2.8.92 AW
; KEINE DREHMOEGLICHKEIT !!!
(DEFUN c:symplac ( / einp); / einp ebene symname)
(SETQ einp (GETPOINT "\nInsert-Point: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp "" "" "0")
)
;----------- Block einfuegen mit Layergenerierung ----14.8.92 AW
; MIT DREHMOEGLICHKEIT !!!
(DEFUN c:sympl_dr ( / einp); / einp ebene symname)
(SETQ einp (GETPOINT "\nInsert-Point: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp "" "" pause)
)
;----------- Block einfuegen mit Layergenerierung ---16.9.93 AW
; MIT DREHMOEGLICHKEIT UND URSPRUNG NACH DEM SETZEN !!!
(DEFUN c:sympldr2 ( / einp drehung groesse)
(setq groesse "1")
(SETQ einp (GETPOINT "\nInsert-Point: "))
(SETQ drehung (GETSTRING "\nRotation: "))
(SETQ groesse (GETSTRING "\nScale: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp groesse groesse drehung)
(COMMAND "_explode" "_last")
)
;----------- Block einfuegen mit Layergenerierung ---21.11.93 AW
; ABFRAGE: SKALIERUNG/ DREHMOEGLICHKEIT UND URSPRUNG NACH DEM SETZEN !!!
(DEFUN c:sympldr1 ( / einp drehung)
(SETQ einp (GETPOINT "\nInsert-Point: "))
(SETQ drehung (GETSTRING "\nRotation: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp "" "" drehung)
(COMMAND "_explode" "_last")
)
;----------- Block einfuegen mit Layergenerierung und Skalierung ---12.2.93 AW
(DEFUN c:sym_scal ( / einp p1 p2); / einp ebene symname)
(SETQ einp (GETPOINT "\nInsert-Point: "))
(SETQ p1 (GETREAL "\nX-Scale: "))
(SETQ p2 (GETREAL "\nY-Scale: "))
(COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
(COMMAND "_insert" symname einp p1 p2 "0")
)
;------------ Farbe aendern - AUFRUF aus POP2--------------------------
(DEFUN c:alt_farb ( / sst_obj neuefarb)
(setq sst_obj (ssget) neuefarb (getstring "\nNew-Color: "))
(command "_change" sst_obj "" "_prop" "_co" neuefarb "")
)
;--------------------------------------------------------------------
(defun block-op (PT0 szoeg auswahl-satz / komponente1 komponente2
seconds element-name gefunden)
;------------------
; Block definieren
;-----------------------------------------------------------
; PT0 - Origin der Baugruppe
; szoeg - Einfuegewinkel
; auswahl-satz - Elemente des Blockes in Auswahlsatz
;------------------------------------------------------------
(setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
(itoa (abs (fix (caddr PT0))))))
(setq komponente2 szoeg)
(setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
(setq element-name (strcat komponente1 komponente2 seconds))
(princ)
(princ (strcat komponente1 "\n"))
(princ (strcat komponente2 "\n"))
(princ (strcat seconds "\n"))
(princ)
(princ (strcat "\n" element-name "\n"))
(princ)
(setq gefunden (tblsearch "block" element-name))
(if (not gefunden)
(progn
(princ)
(command "_block" element-name PT0 auswahl-satz "")
(command "_insert" element-name PT0 "" "" szoeg)
)
(progn
(alert (strcat "\nBlockname: " element-name " already exists." ))
(setq element-name (strcat "x" element-name))
(alert (strcat "\nCorrected blockname: " element-name " .OK!"))
(command "_block" element-name PT0 auswahl-satz "")
(command "_insert" element-name PT0 "" "" szoeg)
)
)
)
(defun bl-name (PT0 / komponente1 seconds)
; 14.4.94
; Verwendung bei Baugruppen, deren Bestandteile aufgelistet
; werden m�ssen.
; Name eines Blockes gleich am Anfang des Programmes festlegen
; - die Einzelkomponenten werden in "C" mit diesem Wert belegt
; - dadurch ist eine eindeutige Gruppenzugeh"rigkeit m"glich
;
(setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
(itoa (abs (fix (caddr PT0))))))
(setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
(setq block-kennung (strcat komponente1 seconds))
(princ)
)
(defun mach-block (PT0 szoeg auswahl-satz / komponente1 komponente2
seconds element-name gefunden)
;------------------
; Block definieren
;-----------------------------------------------------------
; PT0 - Origin der Baugruppe
; szoeg - Einfuegewinkel
; auswahl-satz - Elemente des Blockes in Auswahlsatz
;------------------------------------------------------------
(setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
(itoa (abs (fix (caddr PT0))))))
(setq komponente2 szoeg)
(setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
(setq element-name (strcat komponente1 komponente2 seconds))
(princ)
(princ (strcat komponente1 "\n"))
(princ (strcat komponente2 "\n"))
(princ (strcat seconds "\n"))
(princ)
(princ (strcat "\n" element-name "\n"))
(princ)
(setq gefunden (tblsearch "block" element-name))
(if (not gefunden)
(progn
(princ)
(command "_insert" (strcat "*" lw "/acadsst/menu/a") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/b") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/c") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/artinr") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/beschr") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/menge") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/position") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/gruppe") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/etikette") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_insert" (strcat "*" lw "/acadsst/menu/aufloese") PT0 "" "")
(ssadd (entlast) auswahl-satz)
(command "_block" element-name PT0 auswahl-satz "")
(command "_insert" element-name PT0 "" "" szoeg)
)
(alert "\nBlockname exists. You need HELP !")
)
)
;---------- Attribute aendern - Laenge,Endstueck,Artikel-Nr.--------------------
(defun ATTRIBUTE-AENDERN (M_POSITION M_ETIKETTE M_GRUPPE M_A M_B M_C M_ARTINR
M_BESCHR M_MENGE M_AUFLOESE / objekt typ
attribut-bezeichnung attribut-wert)
(setq objekt (entlast))
(while (not (equal
(cdr (assoc 0 (entget objekt)))
"SEQEND"))
(setq typ
(cdr (assoc 0 (entget objekt))))
(if
(equal typ "ATTRIB")
(progn
(setq ATTRIBUT-BEZEICHNUNG (cdr (assoc 2 (entget objekt))))
(setq ATTRIBUT-WERT (cdr (assoc 1 (entget objekt))))
(if (and (> (strlen M_POSITION) 0) (= ATTRIBUT-BEZEICHNUNG "POSITION"))
(entmod (subst (cons 1 M_POSITION) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_ETIKETTE) 0) (= ATTRIBUT-BEZEICHNUNG "ETIKETTE"))
(entmod (subst (cons 1 M_ETIKETTE) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_GRUPPE) 0) (= ATTRIBUT-BEZEICHNUNG "GRUPPE"))
(entmod (subst (cons 1 M_GRUPPE) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_A) 0) (equal ATTRIBUT-BEZEICHNUNG "A"))
(entmod (subst (cons 1 M_A) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_B) 0) (equal ATTRIBUT-BEZEICHNUNG "B"))
(entmod (subst (cons 1 M_B) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_C) 0) (equal ATTRIBUT-BEZEICHNUNG "C"))
(entmod (subst (cons 1 M_C) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_ARTINR) 0) (equal ATTRIBUT-BEZEICHNUNG "ARTINR"))
(entmod (subst (cons 1 M_ARTINR) (assoc 1 (entget objekt))
(entget objekt)))
)
(if (and (> (strlen M_BESCHR) 0) (equal ATTRIBUT-BEZEICHNUNG "BESCHR"))
(entmod (subst (cons 1 (strcat ATTRIBUT-WERT M_BESCHR))
(assoc 1 (entget objekt)) (entget objekt)))
)
(if (and (> (strlen M_MENGE) 0) (equal ATTRIBUT-BEZEICHNUNG "MENGE"))
(entmod (subst (cons 1 M_MENGE)
(assoc 1 (entget objekt)) (entget objekt)))
)
(if (and (> (strlen M_AUFLOESE) 0) (equal ATTRIBUT-BEZEICHNUNG "AUFLOESE"))
(entmod (subst (cons 1 M_AUFLOESE)
(assoc 1 (entget objekt)) (entget objekt)))
)
) ; Ende ----progn
) ; Ende ----if
(setq objekt (entnext objekt))
)
(setq objekt objekt)
)
;--- Objekt in der DB suchen und Attribut "ndern ---------------
; Parameter:
; ref - handle
; bezeichnung - Attributbezeichnung, die gesucht ist
; wert - neuer Wert
; addition = 0 - Attributbezeichnung wird mit "wert" ersetzt
; 1 - Attributbezeichnung wird mit "wert" erg"nzt
;----------------------------------------------------------------
(defun suchen-aendern ( ref bezeichnung wert addition
/ typ attribut-bezeichnung attribut-wert)
(redraw (handent ref) 3)
(obj-suchen ref)
(redraw (handent ref))
)
(defun obj-suchen (ref)
(setq raus 0)
(setq e (entnext))
(while e
(setq typ (cdr (assoc 0 (entget e))))
(setq blockname (cdr (assoc 2 (entget e))))
(if
(and
(equal (cdr (assoc 5 (entget e))) ref)
(equal typ "INSERT")
(equal (cdr (assoc 66 (entget e))) 1)
)
(progn
(einzel-attr-aendern bezeichnung wert addition)
(setq raus 1) ; rausspringen !!!
)
)
(setq e (entnext e))
(if (= RAUS 1)
(setq e NIL)
)
)
)
(defun einzel-attr-aendern (BEZEICHNUNG WERT ADDITION)
(while (not (= (cdr (assoc 0 (entget e))) "SEQEND"))
(setq typ (cdr (assoc 0 (entget e))))
(if
(equal typ "ATTRIB")
(progn
(setq ATTRIBUT-BEZEICHNUNG (cdr (assoc 2 (entget e))))
(setq ATTRIBUT-WERT (cdr (assoc 1 (entget e))))
(if (= ADDITION 0) ; Attributwert GANZ ersetzen
(progn
(if (equal ATTRIBUT-BEZEICHNUNG BEZEICHNUNG)
(entmod (subst (cons 1 WERT)
(assoc 1 (entget e)) (entget e)))
)
)
)
(if (= ADDITION 1) ; Attributwert ERGAENZEN
(progn
(if (equal ATTRIBUT-BEZEICHNUNG BEZEICHNUNG)
(entmod (subst (cons 1 (strcat ATTRIBUT-WERT WERT))
(assoc 1 (entget e)) (entget e)))
)
)
)
) ; Ende ----progn
)
(setq e (entnext e))
)
)
;--------------------------------------------------------------------------
(setq lw "m:")
(setvar "attreq" 0)
(setq
v-lay (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10")
v-col (list "7" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10")
v-ltyp (list "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" )
)
;----------------------------------------------------------------------------
(prompt "\nSSG-Menu.. (c) 2006 by SCHÖNENBERGER Systeme GmbH - All rights reserved")
(prompt " ")
(princ)