Leaderboard

So just checking, your routine is asking for lisp routine tai However to put this into Lee Macs rename, get the block entity name and replace src with that Replace this line with your selected block entity. (setq src (car (entsel (strcat "\nSelect block reference to " (if cpy "copy & " "") "rename: ")))) and replace this line (and (/= "" (setq new (getstring t (strcat "\nSpecify new block name <" def ">: ")))) with (and (/= "" (setq new "VREVB")) I think that will work, if you can fnd tai lisp then probably be able to put this all together for you

So It seems Autocad uses all uppercase letters for paper and model space. Where BricsCAD only use the first letter uppercase. so when looking a the list with vl-remove it seems to be case sensitive. "*PAPER_SPACE" /= "*Paper_Space" so it wasn't removing them. This should remove them now and not get stuck in a loop. (defun C:LayerColor (/ SS ent lay e blkname blklst entlst lst) (vl-load-com) (if (setq SS (ssget "_X" '((8 . "0") (-4 . "<NOT") (0 . "INSERT") (-4 . "NOT>") (410 . "Model")))) (foreach obj (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS))) (setq ent (vlax-ename->vla-object obj)) (if (and (setq lay (itoa (vla-get-Color ent))) (= lay "256")) (setq lay (itoa (cdr (assoc 62 (tblsearch "layer" (vla-get-Layer ent)))))) ) (if (not (tblsearch "layer" lay)) (entmake (list (cons 0 "LAYER") (cons 100 "AcDbSymbolTableRecord") (cons 100 "AcDbLayerTableRecord") (cons 2 lay) (cons 62 (atoi lay)) (cons 70 0) ) ) ) (vla-put-layer ent lay) ) ) (if (setq blklst (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))) (progn (vlax-for blk blklst (and (eq "AcDbBlockReference" (vla-get-ObjectName blk))) (setq lst (cons (vla-get-Name blk) lst)) ) (setq lst (vl-remove "*PAPER_SPACE" lst)) (setq lst (vl-remove "*MODEL_SPACE" lst)) (foreach blkname lst (setq ent (tblobjname "BLOCK" blkname)) (while (setq ent (entnext ent)) (setq entlst (cons ent entlst)) ) (foreach ent entlst (setq ent (vlax-ename->vla-object ent)) (if (and (setq lay (itoa (vla-get-Color ent))) (= lay "256")) (setq lay (itoa (cdr (assoc 62 (tblsearch "layer" (vla-get-Layer ent)))))) ) (if (not (tblsearch "layer" lay)) (entmake (list (cons 0 "LAYER") (cons 100 "AcDbSymbolTableRecord") (cons 100 "AcDbLayerTableRecord") (cons 2 lay) (cons 62 (atoi lay)) (cons 70 0) ) ) ) (vla-put-layer ent lay) ) ) ) ) (princ) )

Donate to the website I just do this for fun, self learning, and to kill time. Oh and fake internet points.

update this line of code. (if (eq (cdr (assoc 0 (setq ent (entget (car (nentsel "\nSelect Blocks")))))) "INSERT") ;entsel to nentsel aka nested entsel

Ronjonp showed/posted this one a few weeks ago. (setq pt1 (getpoint "\nPoint 1") pt2 (getpoint "\nPoint 2") mpt (mapcar '/ (mapcar '+ pt1 pt2) '(2 2 2)) ) Same as first but using polar and bounding box (vla-getboundingbox (vlax-ename->vla-object rec) 'minpt 'maxpt) ;rec = rectangle entity name. (setq LL (vlax-safearray->list minpt) UR (vlax-safearray->list maxpt) MPT (polar LL (angle LL UR) (/ (distance LL UR) 2)) ) Using geometric center snap. must be closed polyline or spline. (setq rec (vlax-ename->vla-object (car (entsel "\nSelect Rectangle")))) (setq MPT (osnap (vlax-curve-getStartPoint rec) "gcen"))

I got this off this forum once, (defun c:CtrCoo (/ findctr a apt) ;;Center point of a hatch or a rectangle (defun findctr (en / pt) (command "_.Zoom" "_Object" en "") (setq pt (getvar 'viewctr)) (command "_.Zoom" "_Previous") pt ) (setq a (car (entsel "Select Rectangle: : ")) apt (findctr a)) (command "_Text" "_Justify" "_MC" apt 0.1 0 apt) (princ) ) change the last line "(command "_Text"...... " to be a point instead

So I think recently someone was asking about setbylayer - there should be a LISP for that out there easy to get. What do you want to do when you refedit the block by the way, that might alter what commands to use. This is the first bit you are looking for, select a single entity and check that it is a block, you can do similar with ssget, but I can't remember just now how to limit it to a single object selection - that came up recently to I think (setq MyEnt (entget (car (entsel "\nSelect Block"))) ) (while (/= (cdr (assoc 0 MyEnt)) "INSERT") ;; loop if a block ins't selected (setq MyEnt (entget (car (entsel "\nBlock not selected. Select Block"))) ) );end while returns the block entity MyEnt.

This works well on blocks. By the way 90% of the time, I need to deal with exploded bubble dimensions. I will use your first lisp and that will change the color of the text only and that's it. Tanks a lot for your time, you was so helpful.

Still think much easier start with property list. A line, pline etc has a length so does an arc but a circle has circumference so it should appear on same line as length Compare a line to a circle ; Length = 4.69019____________________________________________ ____________________________________________________________ ; Length = 4.69019____________________________________________ ; Circumference 45.609_____________________________________

I was only using one block for testing, and understand why you have them exploded. But you are going to have to use a block to start with for this lisp to work properly. Because their isn't an easy way to select the rest of the entity's if they need properties to be changed. If d value is 0.00 only a prompt will display stating that. If d value is anything other than 0.00 it will explode that block update the text and change all entity's to yellow. See example https://ibb.co/PwYd4Z7 I have also attached the block used in the example. (defun C:rin2 (/ e o p d n x) (vl-load-com) (setvar 'errno 0) (and vlax-get-acad-object (while (/= 52 (getvar 'errno)) (setq e (nentselp "\nSelect text to fill: ")) (cond ((= 7 (getvar 'errno)) (princ "\nMissed, try again.") (setvar 'errno 0) ) ((and e (not (vlax-property-available-p (setq o (vlax-ename->vla-object (car e))) 'TextString))) (princ "\nThis is not a text object.") (setq e nil) ) ((and o (eq (vla-get-Lock (vla-item (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object))) (vla-get-Layer o))) :vlax-true)) (princ "\nThis object is on a locked layer.") (setq e nil) ) (e (if (and (setq p (getpoint "\nSpecify first point: ")) (setq p (cons p (list (getpoint "\nSpecify second point: " p)))) (setq d (abs (/ (apply '- (mapcar 'last (mapcar '(lambda (x) (trans x 1 0)) p))) 1000.0))) ) (cond ((<= d 0.009) (prompt "\nElevation Didn't Change: 0.00 ") ) ((> d 0.009) (if (and (> (length e) 2) (setq n (cdr (assoc 2 (entget (setq x (last (last e)))))))) (progn (setq a (vlax-invoke (vlax-ename->vla-object x) 'explode)) (foreach ent a (if (eq (vla-get-ObjectName ent) "AcDbText") (progn (vla-put-Color ent 2) (vla-put-textstring ent (substr (rtos d 2 3) 1 4)) ) (vla-put-Color ent 2) ) ) (entdel x) (prompt (strcat "\nElevation change is " (substr (rtos d 2 3) 1 4))) ) (progn (vla-put-textstring o (substr (rtos d 2 3) 1 4)) (vla-put-Color o 2) (prompt (strcat "\nElevation change is " (substr (rtos d 2 3) 1 4))) ) ) ) ) (setvar 'errno 52) ) ) (T nil) ) ) ) (princ) ) TEST.dxf

Its for exceed to add to his lisp if he wants.

I fount the problem. When you zoom to max you will se you have multiple intersect point for each line and for some very short distance you have around 6-7 int points. I will modify it tomorrow but dont think this is what you need.

You're welcome anytime. Here is a new one with a few mods for a better performance and alert. (defun c:Test (/ ssn int sel ent ins lst) ;; Tharwat - 28.Jul.2021 ;; (and (princ "\nSelect Main Text : ") (or (setq sel (ssget "_+.:S" '((0 . "*TEXT")))) (alert "Nothing selected on invalid object. Try again") ) (setq ssn (ssname sel 0) ins (Text:Pt_ (entget ssn)) ) (setq int -1 sel (ssget "_X" (list '(0 . "*TEXT") (cons 410 (getvar 'CTAB)))) ) (progn (while (setq int (1+ int) ent (ssname sel int) ) (or (equal ssn ent) (setq lst (cons (list (Text:Pt_ (entget ent)) ent) lst) ) ) ) lst ) (or (< 1 (length lst)) (alert "Number of text is less than two <!>") ) (sssetfirst nil (ssadd (cadr (cadr (vl-sort lst '(lambda (j k) (< (distance ins (car j)) (distance ins (car k))) ) ) ) ) ) ) ) (princ) ) (vl-load-com) (defun Text:Pt_ (get_) (cdr (assoc (if (or (eq "MTEXT" (cdr (assoc 0 get_))) (and (zerop (cdr (assoc 72 get_))) (zerop (cdr (assoc 73 get_))) ) ) 10 11 ) get_ ) ) )

Here is my approach to get the second text that is close to the main selected text. (defun c:Test (/ ssn int sel ent ins lst) ;; Tharwat - 28.Juk.2021 ;; (and (princ "\nSelect Main Text : ") (or (setq sel (ssget "_+.:S" '((0 . "*TEXT")))) (alert "Nothing selected on invalid object. Try again") ) (setq ssn (ssname sel 0) ins (Text:Pt_ (entget ssn)) ) (setq int -1 sel (ssget "_X" '((0 . "*TEXT"))) ) (progn (while (setq int (1+ int) ent (ssname sel int) ) (or (equal ssn ent) (setq lst (cons (list (Text:Pt_ (entget ent)) ent) lst) ) ) ) lst ) (sssetfirst nil (ssadd (cadr (cadr (vl-sort lst '(lambda (j k) (< (distance ins (car j)) (distance ins (car k))) ) ) ) ) ) ) ) (princ) ) (vl-load-com) (defun Text:Pt_ (get_) (cdr (assoc (if (or (eq "MTEXT" (cdr (assoc 0 get_))) (and (zerop (cdr (assoc 72 get_))) (zerop (cdr (assoc 73 get_))) ) ) 10 11 ) get_ ) ) )

Here is my latest revision, but I suggest that you firstly look in *.pat file generated by this routine... Sample is more precise version of superman-logo - S letter sign... As you can see, ACAD is now capable to show pattern, but still there are plenty lacks... Also note that it took on my slow PC half an hour to generate *.pat (around 250 more precise lines)... Still IMHO this is much better when and if you come in situation to try to generate such patterns... Still snaps are even with this precise samples necessity, so watch to fix all lines before routine (look at the swamp and my "fix2dlines2snappts.lsp"... Anyway here is the code : (defun c:savehatchfromstrcur ( / *error* trim0trailing trimlineto80chr acet-geom-ss-extents-accurate intrecsang detk detdxdy detaall aall chksurrpts getp cmde s boundary ch minp maxp w h lil fuzz fuzzz tol des fn a x y p ip dx dy l v k i ooo g ll f al scf ww hh dxdy dyy kk ddx ddy n ) (vl-load-com) (defun *error* ( m ) (if cmde (setvar 'cmdecho cmde)) (if m (prompt m)) (princ) ) (defun trim0trailing ( str / lst ) (setq lst (vl-string->list str)) (setq lst (reverse lst)) (while (= (car lst) 48) (setq lst (cdr lst)) ) (setq lst (reverse lst)) (vl-list->string lst) ) (defun trimlineto80chr ( str / lst ) (setq lst (vl-string->list str)) (setq lst (reverse lst)) (while (> (length lst) 80) (setq lst (cdr lst)) ) (setq lst (reverse lst)) (vl-list->string lst) ) (defun acet-geom-ss-extents-accurate ( ss / layers i lck e layer minp maxp minl maxl ) (if ss (progn (setq layers (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))) (repeat (setq i (sslength ss)) (setq lck nil) (setq e (ssname ss (setq i (1- i)))) (if (= (vla-get-lock (vla-item layers (setq layer (vla-get-layer (vlax-ename->vla-object e))))) :vlax-true) (progn (vla-put-lock (vla-item layers layer) :vlax-false) (setq lck t) ) ) (vla-transformby (vlax-ename->vla-object e) (vlax-tmatrix (append (mapcar '(lambda ( vector origin ) (append (trans vector 1 0 t) (list origin))) (list '(1 0 0) '(0 1 0) '(0 0 1)) (trans '(0 0 0) 0 1)) (list '(0 0 0 1))))) (vla-getboundingbox (vlax-ename->vla-object e) 'minp 'maxp) (vla-transformby (vlax-ename->vla-object e) (vlax-tmatrix (append (mapcar '(lambda ( vector origin ) (append (trans vector 0 1 t) (list origin))) (list '(1 0 0) '(0 1 0) '(0 0 1)) (trans '(0 0 0) 1 0)) (list '(0 0 0 1))))) (if lck (vla-put-lock (vla-item layers layer) :vlax-true) ) (mapcar 'set '(minp maxp) (mapcar 'safearray-value (list minp maxp))) (setq minl (cons minp minl) maxl (cons maxp maxl)) ) (list (apply 'mapcar (cons 'min minl)) (apply 'mapcar (cons 'max maxl))) ) ) ) (defun intrecsang ( minp w h a / r1 r2 r3 r4 d li ip ) (setq r1 (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) '(38 . 0.0) (cons 10 (trans minp 1 0)) (cons 10 (trans (mapcar '+ minp (list w 0.0)) 1 0)) (cons 10 (trans (mapcar '+ minp (list w h)) 1 0)) (cons 10 (trans (mapcar '+ minp (list 0.0 h)) 1 0)) '(210 0.0 0.0 1.0)))) (setq r2 (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) '(38 . 0.0) (cons 10 (trans minp 1 0)) (cons 10 (trans (mapcar '+ minp (list (- w) 0.0)) 1 0)) (cons 10 (trans (mapcar '+ minp (list (- w) h)) 1 0)) (cons 10 (trans (mapcar '+ minp (list 0.0 h)) 1 0)) '(210 0.0 0.0 1.0)))) (setq r3 (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) '(38 . 0.0) (cons 10 (trans minp 1 0)) (cons 10 (trans (mapcar '+ minp (list (- w) 0.0)) 1 0)) (cons 10 (trans (mapcar '+ minp (list (- w) (- h))) 1 0)) (cons 10 (trans (mapcar '+ minp (list 0.0 (- h))) 1 0)) '(210 0.0 0.0 1.0)))) (setq r4 (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) '(38 . 0.0) (cons 10 (trans minp 1 0)) (cons 10 (trans (mapcar '+ minp (list w 0.0)) 1 0)) (cons 10 (trans (mapcar '+ minp (list w (- h))) 1 0)) (cons 10 (trans (mapcar '+ minp (list 0.0 (- h))) 1 0)) '(210 0.0 0.0 1.0)))) (setq d (sqrt (+ (expt w 2) (expt h 2)))) (setq li (entmakex (list '(0 . "LINE") (cons 10 (trans (polar minp a 1e-4) 1 0)) (cons 11 (trans (polar minp a d) 1 0))))) (cond ( (equal a 0.0 1e-8) (setq ip (trans (polar minp 0.0 w) 1 0)) ) ( (equal a (* 0.5 pi) 1e-8) (setq ip (trans (polar minp (* 0.5 pi) h) 1 0)) ) ( (equal a pi 1e-8) (setq ip (trans (polar minp pi w) 1 0)) ) ( (equal a (* 1.5 pi) 1e-8) (setq ip (trans (polar minp (* 1.5 pi) h) 1 0)) ) ( t (cond ( (setq ip (vlax-invoke (vlax-ename->vla-object r1) 'intersectwith (vlax-ename->vla-object li) acextendnone)) ) ( (setq ip (vlax-invoke (vlax-ename->vla-object r2) 'intersectwith (vlax-ename->vla-object li) acextendnone)) ) ( (setq ip (vlax-invoke (vlax-ename->vla-object r3) 'intersectwith (vlax-ename->vla-object li) acextendnone)) ) ( (setq ip (vlax-invoke (vlax-ename->vla-object r4) 'intersectwith (vlax-ename->vla-object li) acextendnone)) ) ) ) ) (mapcar 'entdel (list r1 r2 r3 r4 li)) (setq ip (mapcar '+ '(0 0) (trans ip 0 1))) ) (defun detk ( minp v w h fuzz kk / vx vy k ) (setq vx (car v) vy (cadr v)) (cond ( (and (equal (abs (car v)) w 1e-6) (equal (abs (cadr v)) h 1e-6)) (setq k 1) ) ( (or (and (equal vx 0.0 1e-6) (equal (abs vy) h 1e-6)) (and (equal vy 0.0 1e-6) (equal (abs vx) w 1e-6))) (setq k 1) ) ( (< (abs vx) w) (while (not (or (equal (rem (abs (- (cadr (inters (mapcar '+ minp (list (* w (setq kk ((if (minusp vx) 1- 1+) kk))) 0.0)) (polar (mapcar '+ minp (list (* w kk) 0.0)) (* 0.5 pi) 1.0) minp (mapcar '+ minp v) nil)) (cadr minp))) h) 0.0 fuzz) (equal (rem (abs (- (cadr (inters (mapcar '+ minp (list (* w kk) 0.0)) (polar (mapcar '+ minp (list (* w kk) 0.0)) (* 0.5 pi) 1.0) minp (mapcar '+ minp v) nil)) (cadr minp))) h) h fuzz)))) (setq k (fix (+ 0.5 (/ (abs (- (cadr (inters (mapcar '+ minp (list (* w kk) 0.0)) (polar (mapcar '+ minp (list (* w kk) 0.0)) (* 0.5 pi) 1.0) minp (mapcar '+ minp v) nil)) (cadr minp))) h)))) ) ( (< (abs vy) h) (while (not (or (equal (rem (abs (- (car (inters (mapcar '+ minp (list 0.0 (* h (setq kk ((if (minusp vy) 1- 1+) kk))))) (polar (mapcar '+ minp (list 0.0 (* h kk))) 0.0 1.0) minp (mapcar '+ minp v) nil)) (car minp))) w) 0.0 fuzz) (equal (rem (abs (- (car (inters (mapcar '+ minp (list 0.0 (* h kk))) (polar (mapcar '+ minp (list 0.0 (* h kk))) 0.0 1.0) minp (mapcar '+ minp v) nil)) (car minp))) w) w fuzz)))) (setq k (fix (+ 0.5 (/ (abs (- (car (inters (mapcar '+ minp (list 0.0 (* h kk))) (polar (mapcar '+ minp (list 0.0 (* h kk))) 0.0 1.0) minp (mapcar '+ minp v) nil)) (car minp))) w)))) ) ) (list k kk) ) (defun detdxdy ( k / ddx ddy ) (setq ww (fix (/ (+ (abs (car (mapcar '* v (list k k)))) 1e-2) w)) hh (fix (/ (+ (abs (cadr (mapcar '* v (list k k)))) 1e-2) h))) (cond ( (< 0.0 a (* 0.5 pi)) (setq ooo (mapcar '+ minp (list (* w ww) (* h hh)))) ) ( (< (* 0.5 pi) a pi) (setq ooo (mapcar '+ minp (list (* (- w) ww) (* h hh)))) ) ( (< pi a (* 1.5 pi)) (setq ooo (mapcar '+ minp (list (* (- w) ww) (* (- h) hh)))) ) ( (< (* 1.5 pi) a (* 2.0 pi)) (setq ooo (mapcar '+ minp (list (* w ww) (* (- h) hh)))) ) ) (cond ( (or (equal a 0.0 1e-6) (equal a pi 1e-6) (equal a (* 2.0 pi) 1e-6)) (setq p (mapcar '+ (car li) (list 0.0 h))) ) ( (or (equal a (* 0.5 pi) 1e-6) (equal a (* 1.5 pi) 1e-6)) (setq p (mapcar '+ (car li) (list w 0.0))) ) ( (and (equal (abs (car v)) w 1e-6) (equal (abs (cadr v)) h 1e-6)) (setq p (getp minp a w h 1 1)) ) ( t (setq p (mapcar '+ (car li) (mapcar '- ooo minp))) ) ) (setq ip (inters p (polar p (+ a (* 0.5 pi)) 1.0) (car li) (polar (car li) a 1.0) nil)) (setq ddx (distance (car li) ip) ddy (if (equal (rem (+ a (* 0.5 pi)) (* 2.0 pi)) (angle ip p) 1e-6) (distance ip p) (- (distance ip p)))) (list ddx ddy) ) (defun detaall ( o w h n / unique uniqueang k kk oo l1 l2 l3 l4 ) (defun unique ( l ) (if l (cons (car l) (unique (vl-remove-if '(lambda ( x ) (equal x (car l) 1e-6)) l)))) ) (defun uniqueang ( l ) (if l (cons (car l) (uniqueang (vl-remove-if '(lambda ( x ) (equal (car x) (caar l) 1e-6)) l)))) ) (setq k 0) (repeat n (setq k (1+ k)) (setq kk -1) (repeat (1+ k) (setq kk (1+ kk)) (setq oo (mapcar '+ o (list (* k w) (* kk h)))) (setq l1 (cons oo l1)) ) (repeat k (setq kk (1- kk)) (setq oo (mapcar '+ o (list (* kk w) (* k h)))) (setq l1 (cons oo l1)) ) ) (setq l1 (reverse l1)) (setq l2 (mapcar '(lambda ( x ) (mapcar '+ o (list (- (car (mapcar '- x o))) (cadr (mapcar '- x o))))) l1)) (setq l3 (mapcar '(lambda ( x ) (mapcar '+ o (list (- (car (mapcar '- x o))) (- (cadr (mapcar '- x o)))))) l1)) (setq l4 (mapcar '(lambda ( x ) (mapcar '+ o (list (car (mapcar '- x o)) (- (cadr (mapcar '- x o)))))) l1)) (uniqueang (mapcar '(lambda ( x ) (list (angle o x) (distance o x))) (unique (append l1 l2 l3 l4)))) ) (defun chksurrpts ( dx dy aall / chkdxdy ) (defun chkdxdy ( dx dy aa ll / p pp r ) (setq p (polar (polar (car li) a dx) (+ a (* 0.5 pi)) dy)) (setq pp (inters (polar (car li) a (- l g)) (polar (polar (car li) a (- l g)) aa 1.0) (car li) p nil)) (if (and pp (or (equal (rem ll (distance (polar (car li) a (- l g)) pp)) 0.0 5e-2) (equal (rem ll (distance (polar (car li) a (- l g)) pp)) (distance (polar (car li) a (- l g)) pp) 5e-2))) (setq r t) ) r ) (vl-every '(lambda ( x ) (chkdxdy dx dy (car x) (cadr x))) aall) ) (defun getp ( o a w h ww hh / r c d p pp dd ) (setq d 1e+99) (cond ( (< 0.0 a (* 0.5 pi)) (setq r -1) (repeat (1+ ww) (setq c -1) (setq r (1+ r)) (repeat (1+ hh) (setq c (1+ c)) (setq p (mapcar '+ o (list (* r w) (* c h)))) (if (and (or (/= r 0) (/= c 0)) (or (/= r ww) (/= c hh)) (< (setq dd (distance p (inters p (polar p (+ a (* 0.5 pi)) 1.0) o (polar o a 1.0) nil))) d)) (setq pp p d dd) ) ) ) ) ( (< (* 0.5 pi) a pi) (setq r -1) (repeat (1+ ww) (setq c -1) (setq r (1+ r)) (repeat (1+ hh) (setq c (1+ c)) (setq p (mapcar '+ o (list (* r (- w)) (* c h)))) (if (and (or (/= r 0) (/= c 0)) (or (/= r ww) (/= c hh)) (< (setq dd (distance p (inters p (polar p (+ a (* 0.5 pi)) 1.0) o (polar o a 1.0) nil))) d)) (setq pp p d dd) ) ) ) ) ( (< pi a (* 1.5 pi)) (setq r -1) (repeat (1+ ww) (setq c -1) (setq r (1+ r)) (repeat (1+ hh) (setq c (1+ c)) (setq p (mapcar '+ o (list (* r (- w)) (* c (- h))))) (if (and (or (/= r 0) (/= c 0)) (or (/= r ww) (/= c hh)) (< (setq dd (distance p (inters p (polar p (+ a (* 0.5 pi)) 1.0) o (polar o a 1.0) nil))) d)) (setq pp p d dd) ) ) ) ) ( t (setq r -1) (repeat (1+ ww) (setq c -1) (setq r (1+ r)) (repeat (1+ hh) (setq c (1+ c)) (setq p (mapcar '+ o (list (* r w) (* c (- h))))) (if (and (or (/= r 0) (/= c 0)) (or (/= r ww) (/= c hh)) (< (setq dd (distance p (inters p (polar p (+ a (* 0.5 pi)) 1.0) o (polar o a 1.0) nil))) d)) (setq pp p d dd) ) ) ) ) ) pp ) (setq cmde (getvar 'cmdecho)) (setvar 'cmdecho 0) (alert "SAVE DWG BEFORE APPLYING THIS ROUTINE...\nSet SNAP to ON and draw boundary rectangle and hatching geometry (lines) inside boundary. IF YOU HAVE STRAIGHT POLYLINES INSIDE BOUNDARY, YOU MUST EXPLODE THEM TO LINES AND RESTART ROUTINE... SNAP must be 0.1x0.1 or greater - best 0.5x0.5...") (while (or (prompt "\nSelect boundary rectangle and hatching geometry...") (not (setq s (ssget '((-4 . "<or") (0 . "LINE") (-4 . "<and") (0 . "LWPOLYLINE") (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>") (-4 . "and>") (-4 . "or>"))))) (if s (not (equal (mapcar 'last (acet-geom-ss-extents-accurate s)) '(0.0 0.0) 1e-6)) ) ) (prompt "\nEmpty sel set or selected geometry not planar with WCS...") ) (setq boundary (ssname (ssget "_C" (setq oo (car (acet-geom-ss-extents-accurate s))) oo '((0 . "LWPOLYLINE") (90 . 4) (-4 . "&=") (70 . 1) (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>"))) 0)) (initget "Yes No") (setq ch (getkword "\nDo you want to implement boundary into hatch [Yes/No] <No> : ")) (mapcar 'set '(minp maxp) (acet-geom-ss-extents-accurate (ssadd boundary))) (setq w (- (car maxp) (car minp)) h (- (cadr maxp) (cadr minp))) (if (= ch "Yes") (progn (setq lil (cons (list (mapcar '+ '(0 0) minp) (mapcar '+ (list w 0) minp)) lil)) (setq lil (cons (list (mapcar '+ (list w 0) minp) (mapcar '+ '(0 0) maxp)) lil)) (setq lil (cons (list (mapcar '+ '(0 0) maxp) (mapcar '+ (list (- w) 0) maxp)) lil)) (setq lil (cons (list (mapcar '+ (list (- w) 0) maxp) (mapcar '+ '(0 0) minp)) lil)) ) ) (ssdel boundary s) (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) (setq lil (cons (list (mapcar '+ '(0 0) (trans (cdr (assoc 10 (entget e))) 0 1)) (mapcar '+ '(0 0) (trans (cdr (assoc 11 (entget e))) 0 1))) lil)) ) (setq lil (reverse lil)) (initget 6) (setq fuzz (getreal "\nSpecify fuzz factor for determining gap - smallest fuzz <1e-6> : ")) (if (null fuzz) (setq fuzz 1e-6) ) (initget 6) (setq tol (getreal "\nSpecify tolerance value for fullfilling gap - delta-y ratio expression (< (/ (abs g) (abs dy)) tol) - biggest tol ; Note that if this value is too big ACAD may not display hatch even though it's correct, so you must lower this value - smaller than with your previous attempt, but when you find solution for displaying hatch - it may not be so accurate, so you should raise value - all until you find satisfactory solution for your pattern - default is <3.3e+8> : ")) (if (null tol) (setq tol 3.3e+8) ) (initget 6) (setq n (getint "\nSpecify number of checking rings around origin point (1 - less reliable - fastest; 2 - normal; 3 - more reliable - slowest; ... ) <3> : ")) (if (null n) (setq n 3) ) (setq fuzzz fuzz) (setq aall (detaall minp w h n)) (initget 1) (setq des (getstring "\nSpecify description : ")) (while (or (not (snvalid des)) (> (strlen des) 8)) (prompt "\nSpecified string not valid, or number of characters greater than 8...") (initget 1) (setq des (getstring "\nSpecify description : ")) ) (setq fn (getfiled "Specify PATTERN file..." (strcat (getvar 'roamablerootprefix) "support\\") "pat" 1)) (foreach li lil (setq a (angle (car li) (cadr li))) (setq l (distance (car li) (cadr li))) (setq x (caar li) y (cadar li)) (setq ip (intrecsang minp w h a)) (setq v (mapcar '- ip minp)) (setq fuzz fuzzz) (setq k (detk minp v w h (setq fuzz (* 100000.0 fuzz)) 0)) (setq kk k) (gc) (while (and (/= (car k) 1) (< (car k) 3000) (> fuzz fuzzz)) (setq kk k) (setq k (detk minp v w h (setq fuzz (/ fuzz 10.0)) (if (or (and (< (abs (car v)) w) (minusp (car v))) (and (< (abs (cadr v)) h) (minusp (cadr v)))) (1+ (cadr k)) (1- (cadr k))))) (gc) ) (if (/= (car k) 1) (setq k kk) ) (setq g (- (- (distance minp (mapcar '+ minp (mapcar '* v (list (car k) (car k))))) l))) (setq dyy 1e+99) (setq i 0) (setq dx nil dy nil) (repeat (if (= (car k) 1) 1 (1- (car k))) (if (and (< (abs (cadr (setq dxdy (detdxdy (setq i (1+ i)))))) (abs dyy)) (> (abs (cadr dxdy)) 1e-8) (< (/ (abs g) (abs (cadr dxdy))) tol)) (progn (setq ddx (car dxdy) ddy (cadr dxdy) dyy ddy) (if (or (not (or (equal a 0.0 1e-6) (equal a (* 0.5 pi) 1e-6) (equal a pi 1e-6) (equal a (* 1.5 pi) 1e-6) (equal a (* 2.0 pi) 1e-6))) (/= (car k) 1)) (if (chksurrpts ddx ddy aall) (setq dx ddx dy ddy) ) (setq dx ddx dy ddy) ) ) ) ) (gc) (if (and (null dx) (null dy)) (progn (setq k (detk minp v w h fuzzz (if (or (and (< (abs (car v)) w) (minusp (car v))) (and (< (abs (cadr v)) h) (minusp (cadr v)))) (1+ (cadr k)) (1- (cadr k))))) (gc) (setq g (- (- (distance minp (mapcar '+ minp (mapcar '* v (list (car k) (car k))))) l))) (repeat (- (1- (car k)) i) (if (and (< (abs (cadr (setq dxdy (detdxdy (setq i (1+ i)))))) (abs dyy)) (> (abs (cadr dxdy)) 1e-8) (< (/ (abs g) (abs (cadr dxdy))) tol)) (progn (setq ddx (car dxdy) ddy (cadr dxdy) dyy ddy) (if (not (or (equal a 0.0 1e-6) (equal a (* 0.5 pi) 1e-6) (equal a pi 1e-6) (equal a (* 1.5 pi) 1e-6) (equal a (* 2.0 pi) 1e-6))) (if (chksurrpts ddx ddy aall) (setq dx ddx dy ddy) ) (setq dx ddx dy ddy) ) ) ) ) (gc) ) ) (if (and (null dx) (null dy)) (if (and ddx ddy) (setq dx ddx dy ddy) ) ) (setq ll (cons (list (cvunit a "radian" "degree") x y dx dy l g) ll)) (setq al (cons (cvunit a "radian" "degree") al)) ) (setq ll (reverse ll)) (setq al (reverse al)) (initget 6) (setq scf (getreal "\nSpecify scale factor for multiplication hatch data <1.0> : ")) (if (null scf) (setq scf 1.0) ) (setq ll (mapcar '(lambda ( x ) (mapcar '(lambda ( y ) (* y scf)) x)) ll)) (setq f (open fn "w")) (write-line (strcat "*" des ", " des) f) (setq k -1) (foreach li ll (setq k (1+ k)) (if (zerop (last li)) (write-line (trimlineto80chr (strcat (trim0trailing (rtos (nth k al) 2 8)) "," (trim0trailing (rtos (cadr li) 2 8)) "," (trim0trailing (rtos (caddr li) 2 8)) "," (trim0trailing (rtos (nth 3 li) 2 8)) "," (trim0trailing (rtos (nth 4 li) 2 8)))) f) (write-line (trimlineto80chr (strcat (trim0trailing (rtos (nth k al) 2 8)) "," (trim0trailing (rtos (cadr li) 2 8)) "," (trim0trailing (rtos (caddr li) 2 8)) "," (trim0trailing (rtos (nth 3 li) 2 8)) "," (trim0trailing (rtos (nth 4 li) 2 8)) "," (trim0trailing (rtos (nth 5 li) 2 8)) "," (trim0trailing (rtos (nth 6 li) 2 8)))) f) ) ) (close f) (*error* nil) ) In attachment is my *.pat file... Regards, M.R. HTH. sups-n.pat