Blöcke extrahieren in Datei (Autodesk/Rund um AutoCAD)

Hi,
ich hab' auch noch einen:

Code:

;;; erzeugt aus allen internen Blöcken Wblöcke im Pfad:
;;; c:\Temp\bout[Date]
(defun c:block-out (/ PATH XREF-LST OLD-CMD OLD-FDIA MAP-CHK)
(setq xref-lst (VON-TABLE 14)) ;_ Liste erstellen, nur interne Blocks
(if (not xref-lst)
(alert
"Keine Blöcke in aktueller Zeichnung definiert! Funktionsende."
) ;_ end of princ
(progn
(setq old-fdia (getvar "filedia") ;_ save sysvars
old-cmd (getvar "cmddia")
) ;_ end setq
(setvar "filedia" 0)
(setvar "cmddia" 0)
(setq path (create-path)
map-chk (findfile "acadmap.arx")
) ;_ end setq
(wait-a-little) ;_ Warten auf Ordner-Erstellung....
(foreach elem xref-lst
(if map-chk ;_ Acad-Map aktiv!
;;; Kommandozeile bei Autodesk Map 5
(command "_.-wblock" (strcat path "\\" elem ".dwg") elem "_n")
;;; Komandozeile ohne Map
(command "_.-wblock" (strcat path "\\" elem ".dwg") elem)
)
)
(setvar "filedia" old-fdia) ;_ restore sysvars
(setvar "cmddia" old-cmd)
(alert (strcat "OK, lokale Blöcke in Ordner: \"" (strcase path) "\" exportiert !"))
)
)
(princ)
)

;;; Pgm muß 'n Waitstate einlegen, weil die Erstellung des Export-Ordner über die Shell
;;; eben 'n bischen dauert...
(defun wait-a-little (/ WAITCURSOR WAITTIME)
(setq waittime (+ (getvar "cdate") 0.000002))
(while (<= (getvar "cdate") waittime)
(princ)
)
)
;;; erzeugt 'nen "Timestamp"-Ordner
;;; Dies sollte eigentlich reichen, um diesen "unique" im Temp-Verzeichnis zu haben zu haben
(defun create-path (/ RETVAL SHELLCMD)
(setq retval (strcat
(vl-filename-directory (vl-filename-mktemp)) ;_ finde Temp-Verzeichnis
"\\"
(menucmd
"M=$(edtime,$(getvar,date),DD MONTH YYYY-HH.MM.SS)" ;_ erzeuge Timestamp-Ordner Namen
) ;_ end menucmd
) ;_ end strcat
shellcmd (strcat "md " "\"" retval "\"")
) ;_ end setq
(command "_.shell" shellcmd)
retval
) ;_ end defun
;;; Auszug aus AI_TABLE:
;;; (ai_table <table name> <bit> )
;;;
;;; Returns a list of items in the specified table. The bit values have the
;;; following meaning:
;;; 0 List all items in the specified table.
;;; 1 Do not list Layer 0 and Linetype CONTINUOUS.
;;; 2 Do not list anonymous blocks or anonymous groups.
;;; A check against the 70 flag for the following bit:
;;; 1 anonymous block/group
;;; 4 Do not list externally dependant items.
;;; A check against the 70 flag is made for any of the following
;;; bits, which add up to 48:
;;; 16 externally dependant
;;; 32 resolved external or dependant
;;; 8 Do not list Xrefs.
;;; A check against the 70 flag for the following bit:
;;; 4 external reference
;;; 16 Add BYBLOCK and BYLAYER items to list.
;;;

(defun VON-TABLE (Bit / BLCK-LST RES-LST TABLDATA FFIND SUPP-DAT)
(setq supp-dat "ai_utils.lsp")
(if (null AI_TABLE)
(progn
(setq ffind (findfile supp-dat))
(if (not ffind)
(progn
(alert (strcat "Kann \"" (strcase supp-dat) "\" nicht finden."
"\nÜberprüfen Sie Ihre Suchpfadeinstellungen..."
"\n\n....Funktionsabbruch !")
)
(exit)
)
(load supp-dat)
)
)
)
(setq RES-LST '()
BLCK-LST (AI_TABLE "BLOCK" bit)
) ;_ end of setq
(if (and BLCK-LST (= bit 6)) ;_ Handling nur für Xref
(progn
(foreach ELEM BLCK-LST
(setq TABLDATA (entget (tblobjname "BLOCK" ELEM)))
(if (not (zerop (logand 4 (cdr (assoc 70 TABLDATA)))))
(setq RES-LST (cons ELEM RES-LST))
) ;_ end of if
) ;_ end of foreach
) ;_ end of progn
(setq RES-LST BLCK-LST)
) ;_ end of if
(setq BLCK-LST RES-LST)
) ;_ end of defun
(princ "\nBlock-Out.lsp - erzeugt WBlöcke aus internen Blöcken im Temp-Ordner: \"BLOCK-OUT\"")
(c:block-out) ;_ Autorun, when loaded
(princ)

------------------
Ciao,
Marc

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP