moin,
ich hab hier was im netz gefunden aber leider scheint da noch ein fehler drin zu sein mag das jmd mit ahnung mal testen?
XRbindClip.lsp
;; Command to bind, explode & reverse-xclip XRefs
(defun c:XRBindClip (/ en xlst ss ss1
n m ed pln pld
pll XRB:GetPointOutside pln1
pld1 pll1 ss2 cmd
)
;; Set all to be restored
(command "_undo" "_BEgin")
(setq cmd (getvar "CMDECHO"))
(layerstate-save "XRBindClip-Restore" (+ 1 2 4) nil)
(command ".-layer" "_ON" "*")
(command "_Thaw" "*")
(command "_Unlock" "*" "")
(command "_zoom" "_Extents")
(command "_zoom" ".8x")
;; Search for XRefs
(setq en (tblnext "BLOCK" t) ;Get 1st block
xlst nil ;Initialize XrefList to empty
) ;_ end of setq
(while en ;Repeat until no more blocks found
(if (assoc 1 en) ;Check if it has an XRef path
(setq xlst (cons (cdr (assoc 2 en)) xlst)) ;Add to Xlist
) ;_ end of if
(setq en (tblnext "BLOCK")) ;Get next block
) ;_ end of while
;; Go through this list & bind each
(setq n 0)
(while (< n (length xlst))
(command ".-xref" "_Bind" (nth n xlst))
(setq n (1+ n))
) ;_ end of while
;; Step through entire drawing searching for blocks in this list
(setq ss1 (ssget "x" '((0 . "INSERT")))
m 0
) ;_ end of setq
(while (< m (sslength ss1))
(setq en (ssname ss1 m))
(setq ed (entget en)) ;Get entity's data
(if (and
(= "INSERT" (cdr (assoc 0 ed))) ;Check if block
(member (cdr (assoc 2 ed)) xlst) ;Check if in list
) ;_ end of and
(progn
(command "_xclip" en "" "P") ;Try to generate the polyline
(if (= (getvar "CMDACTIVE") 0) ;Check if successfull
;; If polyline generated
(progn
(setq pln (entlast)
pld (entget pln)
) ;Get the polyline created & its data
;; if it is a polyline
(if (= "LWPOLYLINE" (cdr (assoc 0 pld)))
(progn
;; Step through Polyline's data obtaining each point
(setq pll nil
n 0
) ;_ end of setq
(while (< n (length pld))
(if (= 10 (car (nth n pld))) ;If point list
(setq pll (cons (cdr (nth n pld)) pll))
;Add to list
) ;_ end of if
(setq n (1+ n))
) ;_ end of while
;; Explode & get exploded as selection set
(command "_explode" en "")
(setq ss (ssget "P"))
;; Erase all previous except crossing & inside the polyline
(command "_erase" ss "_Remove" "_CP")
;; send each point
(setq n 0)
(while (< n (length pll))
(command (nth n pll))
(setq n (1+ n))
) ;_ end of while
(command "" "")
;; XClip any blocks contained on boundary
(command "_xclip" "_F")
;; send each point
(setq n 0)
(while (< n (length pll))
(command (nth n pll))
(setq n (1+ n))
) ;_ end of while
(command (nth 0 pll) "" "" "_D")
;Delete their XClips if there
;; WARNING this removes any extra XClip to these blocks
(setq ss2 (ssget "P" '((0 . "INSERT"))))
(if (and ss2 (> (sslength ss2) 0))
(if (= (getvar "CMDACTIVE") 0)
(command "_xclip" "_P")
(command "_N" "_S" pln)
)
) ;_ end of if
(setq ss2 nil)
;; Helper function to get point outside of polyline
(defun XRB:GetPointOutside (pll / n pt ptmax ptmin)
(setq n 1
ptmax (nth 0 pll)
ptmin (nth 0 pll)
) ;_ end of setq
(while (< n (length pll))
(setq pt (nth n pll))
(if (> (car pt) (car ptmax))
(setq ptmax (list (car pt) (cadr ptmax)))
) ;_ end of if
(if (> (cadr pt) (cadr ptmax))
(setq ptmax (list (car ptmax) (cadr pt)))
) ;_ end of if
(if (< (car pt) (car ptmin))
(setq ptmin (list (car pt) (cadr ptmin)))
) ;_ end of if
(if (< (cadr pt) (cadr ptmin))
(setq ptmin (list (car ptmin) (cadr pt)))
) ;_ end of if
(setq n (1+ n))
) ;_ end of while
;; Return point twice the width & height to the right and up
(setq
pt (list (+ (car ptmax)
(abs (- (car ptmax) (car ptmin)))
) ;_ end of +
(+ (cadr ptmax)
(abs (- (cadr ptmax) (cadr ptmin)))
) ;_ end of +
) ;_ end of list
) ;_ end of setq
) ;_ end of defun
;; Create an offsetted polyline
(command "_offset"
"0.01"
pln
(XRB:GetPointOutside pll)
""
) ;_ end of command
;; Get this polyline's points into a list
(setq pln1 (entlast)
pld1 (entget pln1)
pll1 nil
n 0
) ;_ end of setq
(while (< n (length pld1))
(if (= 10 (car (nth n pld1))) ;If point list
(setq pll1 (cons (cdr (nth n pld1)) pll1))
;Add to list
) ;_ end of if
(setq n (1+ n))
) ;_ end of while
;; Lock all layers except those of exploded entities
(command ".-layer" "_Lock" "*")
(setq n 0)
(while (< n (sslength ss))
(setq en (ssname ss n))
(if (setq en (ssname ss n) ed (entget en))
(command "_Unlock" (cdr (assoc 8 ed)))
)
(setq n (1+ n))
)
(command "")
;; Trim all entities around the generated polyline
(command "_trim" pln "" "_F")
;; send each point
(setq n 0)
(while (< n (length pll1))
(command (nth n pll1))
(setq n (1+ n))
) ;_ end of while
(command (nth 0 pll1) "" "")
;; Unlock all layers
(command ".-layer" "_Unlock" "*" "")
(entdel pln) ;Delete the generated polyline
(entdel pln1) ;Delete the offseted polyline
) ;_ end of progn
(command "_explode" en "") ;Else just explode
) ;_ end of if
) ;_ end of progn
;; If no polyline
(progn (command)
(command "_explode" en "") ;Just explode
) ;_ end of progn
) ;_ end of if
) ;_ end of progn
) ;_ end of if
(setq m (1+ m))
) ;_ end of while
;; Restore saved settings
(setvar "CMDECHO" cmd)
(layerstate-restore "XRBindClip-Restore" nil 0)
(layerstate-delete "XRBindClip-Restore")
(command "_undo" "_End")
(princ)
) ;_ end of defun
;|«Visual LISP© Format Options»
(72 2 40 2 T "end of " 60 9 0 0 0 T T nil T)
;*** DO NOT add text below the comment! ***|;
------------------
Aus technischen Gründen befindet sich die Signatur auf der Rückseite dieser Nachricht!
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de (alle Foren)
| 
- 
