;_ Autor: Marc Scherer
;_ Kontakt: marc.scherer@zvo.com
;_ Programmtyp: Lisp-Source; Freeware
;_ Einsetzbar: AutoCAD R14 - Deutsch
;_ Beschreibung:
;_ Dieses Programm sucht Einfügungen eines von Ihnen zu benennenden Blocks,
;_ zoomt eine Einfügung nach der anderen ein, zeigt Informationen zum gezoomten
;_ Block und gibt Ihnen die Möglichkeit eine Markierung zu setzen.
;_ Einsetzbar zum Prüfen vorhandener Einfügungen
;_ Denkbare Programmerweiterungen:
;_ Löschen des gezoomten Bocks
;_ Austauschen gegen einen anderen Block
;_ Ändern diverser Blockparameter
;_ Viel Spass beim Testen.
;_ PS: Wenn Euch das Programm gefällt, lasst es mich wissen...
;_ ********************************************************************
;_ Hauptprogramm: Benutzerführung und Steuerung des Programmablaufs *
;_ ********************************************************************
(defun c:sblock (/ BNAME CLR INDEX LENGTHTXT
OBJKORD OBJLAY OBJNAME OLD_CLAY OLD_CMD
OLD_ERR OLD_EXPERT OLD_OSMODE RCKGABE SBLOCK_ERR
SGET SGETLAENGE
)
;_ Beginn interner Error-Handler
(defun sblock_err (msg)
(princ msg)
(redraw)
(command "_-layer" "_on" "0" "")
(setvar "clayer" old_clay)
(setvar "cmdecho" old_cmd)
(setvar "expert" old_expert)
(setvar "osmode" old_osmode)
(setq *error* old_err)
(princ "\nEin Fehler ist aufgetreten !")
(princ)
) ;_ end defun
;_ Ende interner Error-Handler
;_ Speichern alter Systemvariablen
(setq old_clay (getvar "clayer")
old_cmd (getvar "cmdecho")
old_expert (getvar "expert")
old_osmode (getvar "osmode")
old_err *error*
*error* sblock_err
) ;_ end setq
;_ Setzen erforderlicher Sysvars
(setvar "cmdecho" 0)
(setvar "osmode" 0)
(setvar "clayer" "0")
;_ Frage nach Blocknamen
(setq bname (strcase
(getstring
"\nGeben Sie den Namen des zu suchenden Blocks ein: "
) ;_ end getstring
) ;_ end strcase
) ;_ end setq
;_ Erzeugen eines Auswahlsatzes der alle Blöcke des gesuchten Namens enthält
(setq sget (ssget "X"
(list (cons 0 "INSERT")
(cons 2 bname)
) ;_ end list
) ;_ end ssget
) ;_ end setq
;_ Check, ob überhaupt ein Block eingefügt wurde
(if (= sget nil)
;_ Wenn nein, Programmende
(princ (strcat "\nSorry, keine Blöcke mit Namen: \""
bname
"\" vorhanden. Programmende!"
) ;_ end strcat
) ;_ end princ
;_ Wenn ja, weiter im Programm
(progn
(setvar "expert" 1)
(command "_-layer" "_off" "0" "")
(command "_ucs" "_w")
(setq sgetlaenge
(sslength sget)
lengthtxt (itoa sgetlaenge)
index 0
clr 6
;_ Initialfarbe der Markierung Magenta
) ;_ end setq
;_ Ausgabe der Anzahl gefundener Einfügungen
(princ (strcat "\nInsgesamt \""
lengthtxt
"\" Blöcke vorhanden..."
) ;_ end strcat
) ;_ end princ
;_ Beginn der Schleife
(while (< index sgetlaenge)
;_ Ermitteln der Objektdaten
(setq objname (ssname sget index)
objkord (cdr (assoc 10 (entget objname)))
objlay (cdr (assoc 8 (entget objname)))
) ;_ end setq
;_ Einzoomen des Basispunktes
(command "_zoom" "_c" objkord "25.0")
;_ Markieren des Blockeinfügepunktes
(MARK_BLOCK objkord clr)
;_ Ausgabe von Informationen zum gezoomten Block
(princ (strcat "\nBlock Nr.: \""
(itoa (1+ index))
"\" von insgesamt \""
lengthtxt
"\" eingezoomt. LAYER: \""
objlay
"\""
) ;_ end strcat
) ;_ end princ
;_ Ermitteln was weiter geschehen soll...
;_ Aufruf eines Unterprogrammes
(setq rckgabe (SBAND_NOW objkord))
;_ Auswertung der Rückgabe
(cond
;_ Programmende
((= rckgabe "EXIT") (setq index sgetlaenge))
;_ Farbe der Markierung geändert
((= (type rckgabe) 'INT)
(setq index index
clr rckgabe
) ;_ end setq
(princ "\nNur Farbe der Markierung geändert. Wiederhole...")
)
;_ Weiter im Programm
(T (setq index (1+ index)))
) ;_ end cond
) ;_ end while
) ;_ end progn
) ;_ end if
;_ Zurücksetzen alter Parameter
(command "_-layer" "_on" "0" "")
(redraw)
(setvar "clayer" old_clay)
(setvar "cmdecho" old_cmd)
(setvar "expert" old_expert)
(setvar "osmode" old_osmode)
(setq *error* old_err)
(princ "\nProgramm beendet!")
(princ)
) ;_ end defun
;_ ********************************************************************
;_ Unterprogramm: Ermittelt, was weiter geschehen soll *
;_ ********************************************************************
(defun SBAND_NOW (kord / KWORD SGET2 SGET2LENGTH FANG_POLY OBJ_HL RAUS)
;_ Festlegen welche Antworten es gibt
(initget
"Markieren Naechste Farbe X"
) ;_ end initget
;_ Abfrage der weiteren Vorgehensweise
(setq kword
(getkword
"\nOK, was jetzt?...Markieren/Naechste/eXit/\(Farbe\) <Naechste>:"
) ;_ end getkword
) ;_ end setq
;_ Wenn Antwort=nil, dann...
(if (not kword)
(setq kword "Naechste")
) ;_ end if
;_ Auswertung der Antwort
(cond
;_ Sprung zur nächsten Einfügung
((= kword "Naechste")
(setq raus (princ "\nOK, auf zur naechsten..."))
)
;_ Markieren des Blockeinfügepunktes
((= kword "Markieren") (setq raus (SBMARK_IT kord)))
;_ Ausstieg aus dem Programm
((= kword "X")
(alert "Hiermit ist das Programm beendet!")
(setq raus "EXIT")
)
;_ Farbe der Markierung verändern...
((= kword "Farbe") (setq raus (SBCHANGE_COL)))
) ;_ end cond
;_ Rückgabe der Unterfunktion...
(setq raus raus)
) ;_ end defun
;_ ********************************************************************
;_ Unterprogramm: Legt die Farbe der Markierung fest *
;_ ********************************************************************
(defun SBCHANGE_COL (/ COLR)
(initget "1 2 3 4 5 6 7")
(setq colr
(getint
"\nIn welcher Farbe soll die Hinweismarkierung erscheinen ?
\nFarbnummer: 1-rot,2-gelb,3-grün,4-cyan,5-blau,6-magenta,7-weiss <6>: "
) ;_ end getint
) ;_ end setq
(if (not colr)
(setq colr 6)
) ;_ end if
(setq colr colr)
) ;_ end defun
;_ ********************************************************************
;_ Unterprogramm: Zeichnet einen Ring als *
;_ Markierung des E.pktes auf Layer 0 *
;_ ********************************************************************
(defun SBMARK_IT (pkt /)
(command "_donut" "2" "10" pkt "")
(princ "\nMarkiert auf Layer 0 !")
(princ)
) ;_ end defun
;_ ********************************************************************
;_ Unterprogramm: Erzeugt "virtuelle" Linien zur *
;_ Kennzeichnung des Einfügepunktes *
;_ ********************************************************************
(defun MARK_BLOCK (pkt3 clr / DIAG1 DIAG2 DIAG3
DIAG4 HOCH HOR1 HOR2 RECHTS VEK_LIST
VER1 VER2 MARKSIZE1 MARKSIZE2
)
;_ Setzen der Variablen
(setq rechts (car pkt3)
hoch (cadr pkt3)
;_ Horizontal 1.5
marksize1 (* 0.06 (getvar "viewsize"))
;_ Vertikal 1.0
marksize2 (* 0.04 (getvar "viewsize"))
hor1 (list (- rechts marksize1) hoch)
hor2 (list (+ rechts marksize1) hoch)
ver1 (list rechts (+ hoch marksize1))
ver2 (list rechts (- hoch marksize1))
diag1 (list (- rechts marksize2) (+ hoch marksize2))
diag2 (list (+ rechts marksize2) (- hoch marksize2))
diag3 (list (- rechts marksize2) (- hoch marksize2))
diag4 (list (+ rechts marksize2) (+ hoch marksize2))
;_Erstellen der Vektorenliste
vek_list (list clr hor1 ver1 ver1 hor2 hor2 ver2
ver2 hor1 diag1 diag4 diag4 diag2 diag2
diag3 diag3 diag1
) ;_ end list
;_ end list
) ;_ end setq
;_ "Zeichnen" der virtuellen Linien
(grvecs vek_list)
(princ)
) ;_ end defun
(princ
"\n\"sblock.lsp\" \(C\)1999 by Marc Scherer \(marc.scherer@zvo.com\)\nBlöcke suchen... SBLOCK startet das Programm."
) ;_ end princ
;_ Quietload
(princ)
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP