make pat files

[3dwannab]

@marko_ribar, I get Specified string not valid.

 

Why do you say that generated .pat files are bad? What's the best way to do them? Manually by entering the data?

 

Edit:
Sorry I put testpat.pat as the description. testpat works for both description and filename.

 

Edited June 23 by 3dwannab

[marko_ribar]

On 6/23/2024 at 7:30 PM, 3dwannab said:

@marko_ribar, I get Specified string not valid.

 

Why do you say that generated .pat files are bad? What's the best way to do them? Manually by entering the data?

 

It's a long story... If you analyze *.lsp posted lastly by me, you'll notice that every line is searching for collinearity in a rectangular array of boundaries very far from original line, plus there should be satisfied requirenment that offset of lines meets adjacent boundary at correct distance... If these two clauses are fulfilled, then there should be no problem, and when hatching there should be exact matching of source lines and hatched ones... But more than often these clauses are not fulfilled, and so *.pat files are bad... But you'll never know, maybe someone find some better way to solve those lacks... As far as I can see, making correct *.pat files in rectangular array is heavy task to acomplish; therefore that's why AutoDesk implemented SUPERHATCH command, but it works with blocks and not *.pat files... It seems that for users that are drafters that had no effect on the way they work, and to cut the story, noone had any complainments about hatching with blocks instead of with *.pat files...

Regards, M.R.

Edited June 26 by marko_ribar

[3dwannab]

Thanks for the very clear answer. I will test this program out as I'm trying to create a stone hatch library for the office and will use this script in doing so.

 

To fix your script you can change this line:

 (write-line (strcat "*" des ", " des) f)

 

to:

(write-line (strcat "*" (vl-filename-base fn) ", " des) f)

 

[marko_ribar]

@3dwannab

I've modified my latest version to be just slightly more reliable... My mistake was in sub (removetrailingzeros)... And plus I changed ' (apostrophes) with adequate (function) or (quote) calls... That's all, but I haven't tested it yet on more complex DWGs...

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 )

  (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))

  (defun *error* ( m )
    (if cmde (setvar (quote cmdecho) cmde))
    (if m (prompt m))
    (princ)
  )

  (defun trim0trailing ( str / lst flag )
    (setq lst (vl-string->list str))
    (if (vl-position 46 lst)
      (progn
        (setq lst (reverse lst))
        (while (and (not flag) (or (= (car lst) 46) (= (car lst) 48)))
          (if (= (car lst) 46)
            (setq flag t)
          )
          (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 (function (lambda ( vector origin ) (append (trans vector 1 0 t) (list origin)))) (list (list 1.0 0.0 0.0) (list 0.0 1.0 0.0) (list 0.0 0.0 1.0)) (trans (list 0.0 0.0 0.0) 0 1)) (list (list 0.0 0.0 0.0 1.0)))))
          (vla-getboundingbox (vlax-ename->vla-object e) (quote minp) (quote maxp))
          (vla-transformby (vlax-ename->vla-object e) (vlax-tmatrix (append (mapcar (function (lambda ( vector origin ) (append (trans vector 0 1 t) (list origin)))) (list (list 1.0 0.0 0.0) (list 0.0 1.0 0.0) (list 0.0 0.0 1.0)) (trans (list 0.0 0.0 0.0) 1 0)) (list (list 0.0 0.0 0.0 1.0)))))
          (if lck
            (vla-put-lock (vla-item layers layer) :vlax-true)
          )
          (mapcar (function set) (list (quote minp) (quote maxp)) (mapcar (function safearray-value) (list minp maxp)))
          (setq minl (cons minp minl) maxl (cons maxp maxl))
        )
        (list (apply (function mapcar) (cons (function min) minl)) (apply (function mapcar) (cons (function max) maxl)))
      )
    )
  )

  (defun intrecsang ( minp w h a / r1 r2 r3 r4 d li ip )
    (setq r1 (entmakex (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 1) (cons 38 0.0) (cons 10 (trans minp 1 0)) (cons 10 (trans (mapcar (function +) minp (list w 0.0)) 1 0)) (cons 10 (trans (mapcar (function +) minp (list w h)) 1 0)) (cons 10 (trans (mapcar (function +) minp (list 0.0 h)) 1 0)) (list 210 0.0 0.0 1.0))))
    (setq r2 (entmakex (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 1) (cons 38 0.0) (cons 10 (trans minp 1 0)) (cons 10 (trans (mapcar (function +) minp (list (- w) 0.0)) 1 0)) (cons 10 (trans (mapcar (function +) minp (list (- w) h)) 1 0)) (cons 10 (trans (mapcar (function +) minp (list 0.0 h)) 1 0)) (list 210 0.0 0.0 1.0))))
    (setq r3 (entmakex (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 1) (cons 38 0.0) (cons 10 (trans minp 1 0)) (cons 10 (trans (mapcar (function +) minp (list (- w) 0.0)) 1 0)) (cons 10 (trans (mapcar (function +) minp (list (- w) (- h))) 1 0)) (cons 10 (trans (mapcar (function +) minp (list 0.0 (- h))) 1 0)) (list 210 0.0 0.0 1.0))))
    (setq r4 (entmakex (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 1) (cons 38 0.0) (cons 10 (trans minp 1 0)) (cons 10 (trans (mapcar (function +) minp (list w 0.0)) 1 0)) (cons 10 (trans (mapcar (function +) minp (list w (- h))) 1 0)) (cons 10 (trans (mapcar (function +) minp (list 0.0 (- h))) 1 0)) (list 210 0.0 0.0 1.0))))
    (setq d (sqrt (+ (expt w 2) (expt h 2))))
    (setq li (entmakex (list (cons 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) (quote intersectwith) (vlax-ename->vla-object li) acextendnone)) )
          ( (setq ip (vlax-invoke (vlax-ename->vla-object r2) (quote intersectwith) (vlax-ename->vla-object li) acextendnone)) )
          ( (setq ip (vlax-invoke (vlax-ename->vla-object r3) (quote intersectwith) (vlax-ename->vla-object li) acextendnone)) )
          ( (setq ip (vlax-invoke (vlax-ename->vla-object r4) (quote intersectwith) (vlax-ename->vla-object li) acextendnone)) )
        )
      )
    )
    (mapcar (function entdel) (list r1 r2 r3 r4 li))
    (setq ip (mapcar (function +) (list 0.0 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 (function +) minp (list (* w (setq kk ((if (minusp vx) 1- 1+) kk))) 0.0)) (polar (mapcar (function +) minp (list (* w kk) 0.0)) (* 0.5 pi) 1.0) minp (mapcar (function +) minp v) nil)) (cadr minp))) h) 0.0 fuzz) (equal (rem (abs (- (cadr (inters (mapcar (function +) minp (list (* w kk) 0.0)) (polar (mapcar (function +) minp (list (* w kk) 0.0)) (* 0.5 pi) 1.0) minp (mapcar (function +) minp v) nil)) (cadr minp))) h) h fuzz))))
        (setq k (fix (+ 0.5 (/ (abs (- (cadr (inters (mapcar (function +) minp (list (* w kk) 0.0)) (polar (mapcar (function +) minp (list (* w kk) 0.0)) (* 0.5 pi) 1.0) minp (mapcar (function +) minp v) nil)) (cadr minp))) h))))
      )
      ( (< (abs vy) h)
        (while (not (or (equal (rem (abs (- (car (inters (mapcar (function +) minp (list 0.0 (* h (setq kk ((if (minusp vy) 1- 1+) kk))))) (polar (mapcar (function +) minp (list 0.0 (* h kk))) 0.0 1.0) minp (mapcar (function +) minp v) nil)) (car minp))) w) 0.0 fuzz) (equal (rem (abs (- (car (inters (mapcar (function +) minp (list 0.0 (* h kk))) (polar (mapcar (function +) minp (list 0.0 (* h kk))) 0.0 1.0) minp (mapcar (function +) minp v) nil)) (car minp))) w) w fuzz))))
        (setq k (fix (+ 0.5 (/ (abs (- (car (inters (mapcar (function +) minp (list 0.0 (* h kk))) (polar (mapcar (function +) minp (list 0.0 (* h kk))) 0.0 1.0) minp (mapcar (function +) minp v) nil)) (car minp))) w))))
      )
    )
    (list k kk)
  )

  (defun detdxdy ( k / ddx ddy )
    (setq ww (fix (/ (+ (abs (car (mapcar (function *) v (list k k)))) 1e-2) w)) hh (fix (/ (+ (abs (cadr (mapcar (function *) v (list k k)))) 1e-2) h)))
    (cond
      ( (< 0.0 a (* 0.5 pi))
        (setq ooo (mapcar (function +) minp (list (* w ww) (* h hh))))
      )
      ( (< (* 0.5 pi) a pi)
        (setq ooo (mapcar (function +) minp (list (* (- w) ww) (* h hh))))
      )
      ( (< pi a (* 1.5 pi))
        (setq ooo (mapcar (function +) minp (list (* (- w) ww) (* (- h) hh))))
      )
      ( (< (* 1.5 pi) a (* 2.0 pi))
        (setq ooo (mapcar (function +) 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 (function +) (car li) (list 0.0 h)))
      )
      ( (or (equal a (* 0.5 pi) 1e-6) (equal a (* 1.5 pi) 1e-6))
        (setq p (mapcar (function +) (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 (function +) (car li) (mapcar (function -) 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 (function (lambda ( x ) (equal x (car l) 1e-6))) l))))
    )

    (defun uniqueang ( l )
      (if l (cons (car l) (uniqueang (vl-remove-if (function (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 (function +) o (list (* k w) (* kk h))))
        (setq l1 (cons oo l1))
      )
      (repeat k
        (setq kk (1- kk))
        (setq oo (mapcar (function +) o (list (* kk w) (* k h))))
        (setq l1 (cons oo l1))
      )
    )
    (setq l1 (reverse l1))
    (setq l2 (mapcar (function (lambda ( x ) (mapcar (function +) o (list (- (car (mapcar (function -) x o))) (cadr (mapcar (function -) x o)))))) l1))
    (setq l3 (mapcar (function (lambda ( x ) (mapcar (function +) o (list (- (car (mapcar (function -) x o))) (- (cadr (mapcar (function -) x o))))))) l1))
    (setq l4 (mapcar (function (lambda ( x ) (mapcar (function +) o (list (car (mapcar (function -) x o)) (- (cadr (mapcar (function -) x o))))))) l1))
    (uniqueang (mapcar (function (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 (function (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 (function +) 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 (function +) 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 (function +) 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 (function +) 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 (quote cmdecho)))
  (setvar (quote 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 (list (cons -4 "<or") (cons 0 "LINE") (cons -4 "<and") (cons 0 "LWPOLYLINE") (cons -4 "<not") (cons -4 "<>") (cons 42 0.0) (cons -4 "not>") (cons -4 "and>") (cons -4 "or>")))))
      (if s
        (not (equal (mapcar (function last) (acet-geom-ss-extents-accurate s)) (list 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 (list (cons 0 "LWPOLYLINE") (cons 90 4) (cons -4 "&=") (cons 70 1) (cons -4 "<not") (cons -4 "<>") (cons 42 0.0) (cons -4 "not>"))) 0))
  (initget "Yes No")
  (setq ch (getkword "\nDo you want to implement boundary into hatch [Yes/No] <No> : "))
  (mapcar (function set) (list (quote minp) (quote 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 (function +) (list 0.0 0.0) minp) (mapcar (function +) (list w 0) minp)) lil))
      (setq lil (cons (list (mapcar (function +) (list w 0) minp) (mapcar (function +) (list 0.0 0.0) maxp)) lil))
      (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) maxp) (mapcar (function +) (list (- w) 0) maxp)) lil))
      (setq lil (cons (list (mapcar (function +) (list (- w) 0) maxp) (mapcar (function +) (list 0.0 0.0) minp)) lil))
    )
  )
  (ssdel boundary s)
  (foreach e (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s)))
    (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 10 (entget e))) 0 1)) (mapcar (function +) (list 0.0 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 (quote roamablerootprefix)) "support\\") "pat" 1))
  (while (or (not (snvalid (vl-filename-base fn))) (> (strlen (vl-filename-base fn)) 8))
    (prompt "\nSpecified filename not valid, or number of characters greater than 8...")
    (setq fn (getfiled "Specify PATTERN file..." (strcat (getvar (quote 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 (function -) 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 (function +) minp (mapcar (function *) 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 (function +) minp (mapcar (function *) 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 (function (lambda ( x ) (mapcar (function (lambda ( y ) (* y scf))) x))) ll))
  (setq f (open fn "w"))
  (write-line (strcat "*" (vl-filename-base fn) ", " 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)
)

 

Regards, M.R.

HTH.

Edited June 24 by marko_ribar

[3dwannab]

Thanks @marko_ribar, I'll give it a go and see.

[3dwannab]

It's erroring out for me at this line after the Do you want to implement boundary into hatch: question.

 

   (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 10 (entget e))) 0 1)) (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 11 (entget e))) 0 1))) lil))

 

See the attached test drawing.

 

Hatch Pattern to Make.dwg

[marko_ribar]

@3dwannab

You can easily create orthogonal hatchings in rectangular matrix, but if you have angled lines, then you have to use 0,0 and 1,1 boundary with snappings of 0.01, i.e. you have matrix 100x100 to draw your hatching schema... And you have for this HatchMake.lsp posted at cadalyst ...

Regatds, M.R.

[3dwannab]

Thanks. This hatch doesn't look great at 0.01 grid spacing at a 1x1 square.

 

Is that 0.1 grid thing a limitation of some kind?

 

[marko_ribar]

Look I did something different than that author (don't know his name), but he used trigonometry for generization of angled lines and yes that limitation is too bad... Now looking at your picture, I suppose that this isn't just 100x100 pixels, but I don't know how is it generated... Maybe with the same routine from cadalyst site and user used much densier lines... Actually initialy I started to code my version as I saw his instruction (100x100) for which I was unsatisfied...

That's all of the story...

Edited June 24 by marko_ribar

[3dwannab]

Thanks, that pic is just a screen grab from Sharex. I think the toolpac plugin has a .pat file generator in its suite of tools but it's aroud 250$.

[marko_ribar]

I've found Hatch Maker by Lanny Schiele...

Here is the link : https://cadtips.cadalyst.com/node/tiplisting?keywords=Lanny Schiele Hatch Maker

 

HTH.

M.R.

[pkenewell]

Sorry to invade, but has anyone thought of using SuperHatch in the Express Tools?

https://help.autodesk.com/view/ACD/2024/ENU/index.html?guid=GUID-89FB15FE-28B9-4A51-BACA-A393469EE1A6

[3dwannab]

@pkenewell, unfortunately, everyone in the office uses LT except me.

 

I'm not too fond of superhatch. It's impossible to modify it. At least with a hatch you can add/delete vertex points.

[3dwannab]

I did come across this web app to create hatches along the way in case anyone might find it useful.

 

https://pattycake.io/new/drawing

[3dwannab]

Spamming this post now 

 

Attached are the two different methods. Yours @marko_ribar and the resulting .pat file from the program you posted.

 

Only difference is, yours @marko_ribar doesn't kill the . if the number is rounded to the nearest 1.

 

So yours is:

270.,0.75,0.26,0.,-1.,0.1,-0.9

 

As opposed to:

270,0.75,0.26,0,1,0.1,-0.9

 

MarkoMethod.pat HatchMakeMethod.pat

[marko_ribar]

@3dwannab

You are wrong, see results from (trim0trailing) sub function...

 

(defun trim0trailing ( str / lst flag )
  (setq lst (vl-string->list str))
  (if (vl-position 46 lst)
    (progn
      (setq lst (reverse lst))
      (while (and (not flag) (or (= (car lst) 46) (= (car lst) 48)))
        (if (= (car lst) 46)
          (setq flag t)
        )
        (setq lst (cdr lst))
      )
      (setq lst (reverse lst))
    )
  )
  (vl-list->string lst)
)

 

: (trim0trailing "270.00")
"270"
: (trim0trailing "270.0")
"270"
: (trim0trailing "270.")
"270"
: (trim0trailing "270")
"270"
: (trim0trailing "270.0010")
"270.001"

 

So, it's working as expected...

Edited June 26 by marko_ribar

[marko_ribar]

13 hours ago, pkenewell said:

Sorry to invade, but has anyone thought of using SuperHatch in the Express Tools?

https://help.autodesk.com/view/ACD/2024/ENU/index.html?guid=GUID-89FB15FE-28B9-4A51-BACA-A393469EE1A6

 

SuperHatch is not available in BricsCAD... One more reason why coding for *.pat file makers...

[pkenewell]

6 hours ago, marko_ribar said:

SuperHatch is not available in BricsCAD... One more reason why coding for *.pat file makers...

Understood. It was just a thought at the time before learning more about your needs. Sorry I can't help further.

[marko_ribar]

This capture is from ToolPac chm help file... Basically hatch generator uses the same algorithm as Lanny Schiele Hatch Maker...

 

 

[3dwannab]

11 hours ago, marko_ribar said:

You are wrong, see results from (trim0trailing) sub function...

 

Sorry, I didn't update the code with the latest version.

 

2 hours ago, marko_ribar said:

This capture is from ToolPac chm help file... Basically hatch generator uses the same algorithm as Lanny Schiele Hatch Maker...

 

I guess from looking at that. I used to have it installed for 2020 and never really got a chance to test it out.