Leaderboard

Hi there... I think I've solved hatching for squares - box 0,0 - 1,1 with density 0.001... This means 1000x1000 precision... All I did is I changed Factor from 100 to 1000 and fuzzines from 0.01 to 0.001, or from 0.001 to 0.0001, or from 0.0001 to 0.00001... So, you actually don't even have to snap to snaps - you just draw your pattern and when finished you use (c:round) with tolerance : 0.001... Here are the routines... ;;;CADALYST 10/05 Tip 2065: HatchMaker.lsp Hatch Maker (c) 2005 Larry Schiele ;;;* ====== B E G I N C O D E N O W ====== ;;;* HatchMaker.lsp written by Lanny Schiele at TMI Systems Design Corporation ;;;* Lanny.Schiele@tmisystems.com ;;;* Tested on AutoCAD 2002 & 2006. -- does include a 'VL' function -- should work on Acad2000 on up. (defun C:DrawHatch nil (vl-cmdf "_.UNDO" "_BE") (setq os (getvar "OSMODE")) (setvar "OSMODE" 0) (vl-cmdf "_.UCS" "_W") (vl-cmdf "_.PLINE" "0,0" "0,1" "1,1" "1,0" "_C") (vl-cmdf "_.ZOOM" "_C" "0.5,0.5" 1.1) (setvar "OSMODE" os) (setvar "SNAPMODE" 1) (setvar "SNAPUNIT" (list 0.001 0.001)) (vl-cmdf "_.UNDO" "_E") (alert "Draw pattern within 1x1 box using LINE or POINT entities only...") (alert "When you finished drawing pattern in box 0,0 - 1,1; use (c:round) routine to round entities to nearest 0.001 - that should be your tolerance...") (princ) ) (defun C:SaveHatch ( / round dxf ListToFile user SelSet SelSetSize ssNth Ent EntInfo EntType pt1 pt2 Dist AngTo AngFrom XDir YDir Gap DeltaX DeltaY AngZone Counter Ratio Factor HatchName HatchDescr FileLines FileLines FileName Scaler ScaledX ScaledY RF x y h _AB _BC _AC _AD _DE _EF _EH _FH DimZin ) ;;;* BEGIN NESTED FUNCTIONS (defun round (num) (if (>= (- num (fix num)) 0.5) (fix (1+ num)) (fix num) ) ) (defun dxf (code EnameOrElist / VarType) (setq VarType (type EnameOrElist)) (if (= VarType (read "ENAME")) (cdr (assoc code (entget EnameOrElist))) (cdr (assoc code EnameOrElist)) ) ) (defun ListToFile (TextList FileName DoOpenWithNotepad AsAppend / TextItem File RetVal) (if (setq File (open FileName (if AsAppend "a" "w"))) (progn (foreach TextItem TextList (write-line TextItem File) ) (setq File (close File)) (if DoOpenWithNotepad (startapp "notepad" FileName) ) ) ) (FindFile FileName) ) ;;;* END NESTED FUNCTIONS (princ (strcat "\n." "\n 0,1 ----------- 1,1" "\n | | " "\n | Lines and | " "\n | points must | " "\n | be snapped | " "\n | to nearest | " "\n | 0.001 | " "\n | | " "\n 0,0 ----------- 1,0" "\n." "\nNote: Lines must be drawn within 0,0 to 1,1 and lie on a 0.001 grid." ) ) (textscr) (getstring "\nHit [ENTER] to continue...") (princ "\nSelect 1x1 pattern of lines and/or points for new hatch pattern...") (while (not (setq SelSet (ssget (list (cons 0 "LINE,POINT")))))) (setq ssNth 0 SelSetSize (sslength SelSet) DimZin (getvar "DIMZIN") ) (setvar "DIMZIN" 11) (if (> SelSetSize 0) (princ "\nAnalyaing entities...") ) (while (< ssNth SelSetSize) (setq Ent (ssname SelSet ssNth) EntInfo (entget Ent) EntType (dxf 0 EntInfo) ssNth (+ ssNth 1) ) (cond ( (= EntType "POINT") (setq pt1 (dxf 10 EntInfo) FileLine (strcat "0," (rtos (car pt1) 2 6) "," (rtos (cadr pt1) 2 6) ",0,1,0,-1") ) (princ (strcat "\n" FileLine)) (setq FileLines (cons FileLine FileLines)) ) ( (= EntType "LINE") (setq pt1 (dxf 10 EntInfo) pt2 (dxf 11 EntInfo) Dist (distance pt1 pt2) AngTo (angle pt1 pt2) AngFrom (angle pt2 pt1) IsValid nil ) (if (or (equal (car pt1) (car pt2) 0.00001) (equal (cadr pt1) (cadr pt2) 0.00001) ) (setq DeltaX 0 DeltaY 1 Gap (- Dist 1) IsValid T ) (progn (setq Ang (if (< AngTo pi) AngTo AngFrom) AngZone (fix (/ Ang (/ pi 4))) XDir (abs (- (car pt2) (car pt1))) YDir (abs (- (cadr pt2) (cadr pt1))) Factor 1 RF 1 ) (cond ( (= AngZone 0) (setq DeltaY (abs (sin Ang)) DeltaX (abs (- (abs (/ 1.0 (sin Ang))) (abs (cos Ang)))) ) ) ( (= AngZone 1) (setq DeltaY (abs (cos Ang)) DeltaX (abs (sin Ang)) ) ) ( (= AngZone 2) (setq DeltaY (abs (cos Ang)) DeltaX (abs (- (abs (/ 1.0 (cos Ang))) (abs (sin Ang)))) ) ) ( (= AngZone 3) (setq DeltaY (abs (sin Ang)) DeltaX (abs (cos Ang)) ) ) ) (if (not (equal XDir YDir 0.0001)) (progn (setq Ratio (if (< XDir YDir) (/ YDir XDir) (/ XDir YDir)) RF (* Ratio Factor) Scaler (/ 1 (if (< XDir YDir) XDir YDir)) ) (if (not (equal Ratio (round Ratio) 0.0001)) (progn (while (and (<= Factor 1000) (not (equal RF (round RF) 0.0001)) ) (setq Factor (+ Factor 1) RF (* Ratio Factor) ) ) (if (and (> Factor 1) (<= Factor 1000)) (progn (setq _AB (* XDir Scaler Factor) _BC (* YDir Scaler Factor) _AC (sqrt (+ (* _AB _AB) (* _BC _BC))) _EF 1 x 1 ) (while (< x (- _AB 0.5)) (setq y (* x (/ YDir XDir)) h (if (< Ang (/ pi 2)) (- (+ 1 (fix y)) y) (- y (fix y)) ) ) (if (< h _EF) (setq _AD x _DE y _AE (sqrt (+ (* x x) (* y y))) _EF h ) ) (setq x (+ x 1)) ) (if (< _EF 1) (setq _EH (/ (* _BC _EF) _AC) _FH (/ (* _AB _EF) _AC) DeltaX (+ _AE (if (> Ang (/ pi 2)) (- _EH) _EH)) DeltaY (+ _FH) Gap (- Dist _AC) IsValid T ) ) ) ) ) ) ) ) (if (= Factor 1) (setq Gap (- Dist (abs (* Factor (/ 1 DeltaY)))) IsValid T ) ) ) ) (if IsValid (progn (setq FileLine (strcat (angtos AngTo 0 6) "," (rtos (car pt1) 2 8) "," (rtos (cadr pt1) 2 8) "," (rtos DeltaX 2 8) "," (rtos DeltaY 2 8) "," (rtos Dist 2 8) "," (rtos Gap 2 8) ) ) (princ (strcat "\n" FileLine)) (setq FileLines (cons FileLine FileLines)) ) (princ (strcat "\n * * * Line with invalid angle " (angtos AngTo 0 6) (chr 186) " omitted. * * *")) ) ) ( (princ (strcat "\n * * * Invalid entity " EntType " omitted.")) ) ) ) (setvar "DIMZIN" DimZin) (if (and FileLines (setq HatchDescr (getstring T "\nBriefly describe this hatch pattern: ")) (setq FileName (getfiled "Hatch Pattern File" (strcat (getvar (quote roamablerootprefix)) "support\\") "pat" 1)) ) (progn (if (= HatchDescr "") (setq HatchDescr "Custom hatch pattern") ) (setq HatchName (vl-filename-base FileName) FileLines (cons (strcat "*" HatchName "," HatchDescr) (reverse FileLines)) ) (princ "\n============================================================") (princ (strcat "\nPlease wait while the hatch file is created...\n")) (ListToFile FileLines FileName nil nil) (while (not (findfile FileName))) ; (vl-cmdf "delay" 1500) ; delay required so file can be created and found (silly, but req.) (if (findfile FileName) (princ (strcat "\nHatch pattern '" HatchName "' is ready to use!")) (progn (princ "\nUnable to create hatch pattern file:") (princ (strcat "\n " FileName)) ) ) ) (princ (if FileLines "\nCancelled." "\nUnable to create hatch pattern from selected entities.")) ) (princ) ) ;| (princ "\n ************************************************************** ") (princ "\n** **") (princ "\n* HatchMaker.lsp written by Lanny Schiele -- enjoy! *") (princ "\n* *") (princ "\n* Type in DRAWHATCH to have the environment created to draw. *") (princ "\n* Type in SAVEHATCH to save the pattern you created. *") (princ "\n** **") (princ "\n ************************************************************** ") (princ) |; (defun c:round ( / rounddxf roundvalue round e i k l m s ) (defun rounddxf ( key mod lst / rtn ) (foreach itm lst (if (member (car itm) key) (setq rtn (cons (cons (car itm) (roundvalue (cdr itm) mod)) rtn)) (setq rtn (cons itm rtn)) ) ) (reverse rtn) ) (defun roundvalue ( val mod ) (if (listp val) (mapcar (function (lambda ( x ) (round x mod))) val) (round val mod) ) ) ;; Doug Broad (defun round ( value to ) (setq to (abs to)) (* to (fix (/ ((if (minusp value) - +) value (* to 0.5)) to))) ) (setq l '( ("CIRCLE" 10 40) ("LINE" 10 11) ("LWPOLYLINE" 10) ("INSERT" 10) ("POINT" 10) ) ) (if (null *tol*) (setq *tol* 5.0) ) (initget 6) (if (setq m (getreal (strcat "\nSpecify rounding tolerance <" (rtos *tol*) ">: "))) (setq *tol* m) (setq m *tol*) ) (if (setq s (ssget "_:L" '((0 . "CIRCLE,LINE,LWPOLYLINE,INSERT,POINT")))) (repeat (setq i (sslength s)) (if (setq e (entget (ssname s (setq i (1- i)))) k (cdr (assoc (cdr (assoc 0 e)) l))) (entmod (rounddxf k m e)) ) ) ) (princ) ) HTH. M.R. sups-nn.pat

Here's one that will extend lines to circles and plines that are at the same elevation. (defun c:foo (/ bndry bndrys d d2 el fz lines lo p p p1 p2 p3 s z) (cond ((setq s (ssget ":L" '((0 . "CIRCLE,LINE,LWPOLYLINE")))) (setq fz 0.25) (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) (if (= "LINE" (cdr (assoc 0 (setq el (entget e))))) (setq lines (cons (list e (cdr (assoc 10 el)) (cdr (assoc 11 el))) lines)) (setq bndrys (cons e bndrys)) ) ) (foreach line lines (foreach b bndrys (setq p (vlax-curve-getclosestpointto b (cadr line))) (setq p2 (vlax-curve-getclosestpointto b (caddr line))) (setq d (distance p (cadr line))) (setq d2 (distance p2 (caddr line))) (setq z (cond ((and (<= d d2) (<= d fz)) 'startpoint) ((and (<= d2 d) (<= d2 fz)) 'endpoint) ) ) (cond (z (setq lo (vlax-ename->vla-object (car line))) (if (setq p3 (vlax-invoke lo 'intersectwith (vlax-ename->vla-object b) 1)) (vlax-put lo z (if (< (distance (mapcar '+ p3 '(0 0 0)) p) (distance (mapcar '+ (cdddr p3) '(0 0 0)) p) ) (mapcar '+ p3 '(0 0 0)) (mapcar '+ (cdddr p3) '(0 0 0)) ) ) ) ) ) ) ) ) ) (princ) )

"Breakall.lsp" by CAB on the last post there is an update by 3dwannab Here is an updated version by marko_ribar BreakObjects.lsp - Programs and Scripts - AutoCAD Forums (cadtutor.net) As mentioned by BIGAL, there are some around for wipeouts and placing arcs, etc. Here is a start as well as Lee Mac's Automatic Block Break | Lee Mac Programming (lee-mac.com)