435 lines
14 KiB
Common Lisp
435 lines
14 KiB
Common Lisp
(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)
|