make pat files

[marko_ribar]

But sometimes, calculation of HATCH PAT file by using my method can be very long and I still haven't found a way to speed it... Recently I posted a question at theswamp : http://www.theswamp.org/index.php?topic=55999.0 and I implemented solution in my codes... Read carefully all defuns... You'll see that I coded two global variables for getting partial results of calculations... So routine can be interrupted, but then you should save results into files... The goal is to make hatch by combining all saved *.txt files of *ll* variable... So firstly you apply fist (c:func1), then second, then third and so until you apply all in order I coded them... When you want to continue after interruption you should load *slsthand* global from saved file and repeat procedure on DWG you opened again or not... *slsthand* variable should be smaller after some data had been calculated... You do this all to the end... Finally you combine *.txt files of *ll* variables... Sometimes you can start HATCH generation and you waited long, but then again if DWG is not suitable (SNAPS were wrong or HATCH to complex with dimensions) there can be situation where after interruption you check !*ll* and it returns nil... So in this case you should avoid creating HATCH... Routine and DWG still not suitable for the task... So better save PC and electrical energy for something more useful... Anyway here it is :

 

(defun c:savehatchfromstrcur ( / *error* trim0trailing trimlineto80chr acet-geom-ss-extents-accurate _do-events unit projpt2p1p2 intrecsang cmde s boundary ch e minp maxp w h ww hh lil des fn f a x y no ip dx dy l v k kk fullkl kl kll aa bb o1 o2 o3 o4 ol mindy dxdyl oo ooo g ll al nn scf fuz fuzz fuzzz loop )

  (vl-load-com)

  (defun *error* ( m )
    (if cmde (setvar 'cmdecho cmde))
    (prompt "\nOther command functions after interruption and checking *ll* variable with !*ll* are :\n(c:savelltofile) ; (c:trimslsthand) ; (c:saveslsthandtofile) ; (c:loadslsthandfromfile)...")
    (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 _do-events nil ;;; Returns "" or T in essence
    (gc)
    (repeat 2 (vl-cmdf "_.DELAY" 0) (princ ""))
  ) ;;; remember to turn off cmdecho echoing DELAY; This prevents stalling CAD in loops - i.e. ESC will terminate routine preventing termination of CAD entirely

  (defun unit ( v / d )
    (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
      (mapcar '(lambda ( x ) (/ x d)) v)
    )
  )

  (defun projpt2p1p2 ( p p1 p2 / pp p1t ip )
    (setq pp (trans p 1 (unit (mapcar '- (trans p2 1 0) (trans p1 1 0)))))
    (setq p1t (trans p1 1 (unit (mapcar '- (trans p2 1 0) (trans p1 1 0)))))
    (setq ip (mapcar '+ '(0 0) (trans (list (car p1t) (cadr p1t) (caddr pp)) (unit (mapcar '- (trans p2 1 0) (trans p1 1 0))) 1)))
  )

  (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)))
  )

  (setq *ll* nil)
  (initget "Yes No")
  (setq ch (getkword "\nDo you want to nil *slsthand* variable [Yes/No] <Yes> : "))
  (if (or (= ch "Yes") (null ch))
    (setq *slsthand* nil)
  )
  (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)
  (if (null *slsthand*)
    (setq *slsthand* (mapcar '(lambda ( x ) (cdr (assoc 5 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))))
  )
  (foreach hnd *slsthand*
    (setq e (handent hnd))
    (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 fuzzz (getreal "\nSpecify main fuzz factor <5e-10> : "))
  (if (null fuzzz)
    (setq fuzzz 5e-10)
  )
  (initget "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15")
  (setq ch (getkword "\nSpecify secondary fuzz factor from slowest more reliable to fastest less reliable [1 0.1 / 2 0.05 / 3 0.025 / 4 0.0125 / 5 0.00625 / 6 0.003125 / 7 0.0015625 / 8 0.00078125 / 9 0.000390625 / 10 0.0001953125 / 11 0.00009765625 / 12 0.000048828125 / 13 0.0000244140625 / 14 0.00001220703125 / 15 0.000006103515625] <15 0.000006103515625> : "))
  (cond
    ( (null ch)
      (setq fuzz 0.000006103515625)
    )
    ( (= ch "1")
      (setq fuzz 0.1)
    )
    ( (= ch "2")
      (setq fuzz 0.05)
    )
    ( (= ch "3")
      (setq fuzz 0.025)
    )
    ( (= ch "4")
      (setq fuzz 0.0125)
    )
    ( (= ch "5")
      (setq fuzz 0.00625)
    )
    ( (= ch "6")
      (setq fuzz 0.003125)
    )
    ( (= ch "7")
      (setq fuzz 0.0015625)
    )
    ( (= ch "8")
      (setq fuzz 0.00078125)
    )
    ( (= ch "9")
      (setq fuzz 0.000390625)
    )
    ( (= ch "10")
      (setq fuzz 0.0001953125)
    )
    ( (= ch "11")
      (setq fuzz 0.00009765625)
    )
    ( (= ch "12")
      (setq fuzz 0.000048828125)
    )
    ( (= ch "13")
      (setq fuzz 0.0000244140625)
    )
    ( (= ch "14")
      (setq fuzz 0.00001220703125)
    )
    ( (= ch "15")
      (setq fuzz 0.000006103515625)
    )
  )
  (initget "da dy")
  (setq ch (getkword "\nChoose option - search by min da (angle) or min dy (offset) [da/dy] <dy> : "))
  (if (null ch)
    (setq ch "dy")
  )
  (initget "Yes No")
  (setq fullkl (getkword "\nDo you want full checking or depending of secondary fuzz factor you specified [Yes/No] <No> : "))
  (if (null fullkl)
    (setq fullkl "No")
  )
  (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 x (caar li) y (cadar li))
    (setq l (distance (car li) (cadr li)))
    (setq ip (intrecsang minp w h a))
    (setq v (mapcar '- ip minp))
    (setq k 0 loop t)
    (_do-events)
    (while loop
      (while (and (setq k (1+ k)) (if (zerop (rem k 2000)) (_do-events) T) (if (= fullkl "Yes") (setq kl (cons k kl)) T) (not (and (or (equal (/ (* k (abs (car v))) w) (fix (/ (* k (abs (car v))) w)) fuzz) (equal (/ (* k (abs (car v))) w) (fix (1+ (/ (* k (abs (car v))) w))) fuzz)) (or (equal (/ (* k (abs (cadr v))) h) (fix (/ (* k (abs (cadr v))) h)) fuzz) (equal (/ (* k (abs (cadr v))) h) (fix (1+ (/ (* k (abs (cadr v))) h))) fuzz))))))
      (if (= fullkl "No")
        (if (not (vl-position k kl))
          (setq kl (cons k kl))
        )
      )
      (if (and (or (equal (/ (* k (abs (car v))) w) (fix (/ (* k (abs (car v))) w)) fuzzz) (equal (/ (* k (abs (car v))) w) (fix (1+ (/ (* k (abs (car v))) w))) fuzzz)) (or (equal (/ (* k (abs (cadr v))) h) (fix (/ (* k (abs (cadr v))) h)) fuzzz) (equal (/ (* k (abs (cadr v))) h) (fix (1+ (/ (* k (abs (cadr v))) h))) fuzzz)))
        (setq loop nil)
      )
    )
    (setq ooo (mapcar '+ minp (mapcar '* v (list k k))))
    (setq g (- (- (distance minp ooo) l)))
    (setq kk k k 0 fuz (* fuzz 2.0))
    (if (vl-position kk kl)
      (setq kl (vl-remove kk kl))
    )
    (if (and (or (equal (/ (* 1 (abs (car v))) w) (fix (/ (* 1 (abs (car v))) w)) fuzzz) (equal (/ (* 1 (abs (car v))) w) (fix (1+ (/ (* 1 (abs (car v))) w))) fuzzz)) (or (equal (/ (* 1 (abs (cadr v))) h) (fix (/ (* 1 (abs (cadr v))) h)) fuzzz) (equal (/ (* 1 (abs (cadr v))) h) (fix (1+ (/ (* 1 (abs (cadr v))) h))) fuzzz)))
      (progn
        (setq k 1)
        (setq oo (mapcar '+ minp (mapcar '* v (list k k))))
        (setq g (- (- (distance minp oo) l)))
        (setq no (car li))
        (setq ip (projpt2p1p2 no (car li) (cadr li)))
      )
      (progn
        (_do-events)
        (while (if (null kl) (<= fuz 0.5))
          (while (and (setq k (1+ k)) (if (zerop (rem k 2000)) (_do-events) T) (/= k kk) (not (and (or (equal (/ (* k (abs (car v))) w) (fix (/ (* k (abs (car v))) w)) fuz) (equal (/ (* k (abs (car v))) w) (fix (1+ (/ (* k (abs (car v))) w))) fuz)) (or (equal (/ (* k (abs (cadr v))) h) (fix (/ (* k (abs (cadr v))) h)) fuz) (equal (/ (* k (abs (cadr v))) h) (fix (1+ (/ (* k (abs (cadr v))) h))) fuz))))))
          (if (/= k kk)
            (if (not (vl-position k kl))
              (setq kl (cons k kl))
            )
            (if (null kl)
              (setq k 0 fuz (* fuz 2.0))
            )
          )
        )
        (if (= fullkl "No")
          (progn
            (setq aa 1.0 bb 2.0)
            (while (null kll)
              (setq aa (1+ aa) bb (1+ bb))
              (setq kll (vl-remove-if '(lambda ( x ) (or (< x (/ kk bb)) (> x (* aa (/ kk bb))))) kl))
            )
          )
        )
        (setq e 0)
        (_do-events)
        (foreach q (if (= fullkl "No") kll kl)
          (if (zerop (rem (setq e (1+ e)) 2000)) (_do-events))
          (foreach k (if (= fullkl "No") (list (1- q) q (1+ q)) (list q))
            (setq ww (* w (fix (if (and (minusp (car v)) (< (abs (car v)) w)) (1- (/ (* k (car v)) w)) (/ (* k (car v)) w)))))
            (setq hh (* h (fix (if (and (minusp (cadr v)) (< (abs (cadr v)) h)) (1- (/ (* k (cadr v)) h)) (/ (* k (cadr v)) h)))))
            (foreach oo (mapcar '(lambda ( x ) (mapcar '+ minp (list ww hh) x)) (list (list 0 0) (list w 0) (list w h) (list 0 h) (list (- w) h) (list (- w) 0) (list (- w) (- h)) (list 0 (- h)) (list w (- h))))
              (if (= ch "dy")
                (progn
                  (setq no (mapcar '+ oo (mapcar '- (car li) minp)))
                  (setq ip (projpt2p1p2 no (car li) (cadr li)))
                  (if (not (equal no ip 1e-6))
                    (progn
                      (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
                      (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
                    )
                  )
                  (if dxdyl
                    (if (> (cadr (car dxdyl)) dy)
                      (setq dxdyl (cdr dxdyl) dxdyl (cons (list dx dy) dxdyl))
                    )
                    (setq dxdyl (cons (list dx dy) dxdyl))
                  )
                )
                (progn
                  (if ol
                    (if (> 
                          (max
                            (abs (cond ( (and (> 0.0 a (* 0.5 pi)) (> (* 1.5 pi) (angle minp (car ol)) (* 2 pi))) (- (angle minp (car ol)) (+ a pi pi)) ) ( (and (> 0.0 (angle minp (car ol)) (* 0.5 pi)) (> (* 1.5 pi) a (* 2 pi))) (- (+ (angle minp (car ol)) pi pi) a) ) ( t (- (angle minp (car ol)) a) )))
                            (abs (cond ( (and (> 0.0 (rem (+ pi pi a pi) (+ pi pi)) (* 0.5 pi)) (> (* 1.5 pi) (angle ooo (car ol)) (* 2 pi))) (- (angle ooo (car ol)) (+ (rem (+ pi pi a pi) (+ pi pi)) pi pi)) ) ( (and (> 0.0 (angle ooo (car ol)) (* 0.5 pi)) (> (* 1.5 pi) (rem (+ pi pi a pi) (+ pi pi)) (* 2 pi))) (- (+ (angle ooo (car ol)) pi pi) (rem (+ pi pi a pi) (+ pi pi))) ) ( t (- (angle ooo (car ol)) (rem (+ pi pi a pi) (+ pi pi))) )))
                          )
                          (max
                            (abs (cond ( (and (> 0.0 a (* 0.5 pi)) (> (* 1.5 pi) (angle minp oo) (* 2 pi))) (- (angle minp oo) (+ a pi pi)) ) ( (and (> 0.0 (angle minp oo) (* 0.5 pi)) (> (* 1.5 pi) a (* 2 pi))) (- (+ (angle minp oo) pi pi) a) ) ( t (- (angle minp oo) a) )))
                            (abs (cond ( (and (> 0.0 (rem (+ pi pi a pi) (+ pi pi)) (* 0.5 pi)) (> (* 1.5 pi) (angle ooo oo) (* 2 pi))) (- (angle ooo oo) (+ (rem (+ pi pi a pi) (+ pi pi)) pi pi)) ) ( (and (> 0.0 (angle ooo oo) (* 0.5 pi)) (> (* 1.5 pi) (rem (+ pi pi a pi) (+ pi pi)) (* 2 pi))) (- (+ (angle ooo oo) pi pi) (rem (+ pi pi a pi) (+ pi pi))) ) ( t (- (angle ooo oo) (rem (+ pi pi a pi) (+ pi pi))) )))
                          )
                        )
                      (setq ol (cdr ol) ol (cons oo ol))
                    )
                    (setq ol (cons oo ol))
                  )
                )
              )
            )
          )
        )
        (if (= ch "dy")
          (progn
            (setq dx (car (car dxdyl)) dy (cadr (car dxdyl)))
          )
          (progn
            (setq oo (car ol))
            (setq no (mapcar '+ oo (mapcar '- (car li) minp)))
            (setq ip (projpt2p1p2 no (car li) (cadr li)))
            (if (not (equal no ip 1e-6))
              (progn
                (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
                (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
              )
            )
          )
        )
        (setq dxdyl nil kl nil kll nil ol nil)
      )
    )
    (if (or (equal no ip 1e-6) (equal (car li) ip 1e-6))
      (progn
        (cond
          ( (and (>= a 0.0) (< a (* 0.5 pi)))
            (setq no (list x (+ y h)))
          )
          ( (and (>= a (* 0.5 pi)) (< a pi))
            (setq no (list (- x w) y))
          )
          ( (and (>= a pi) (< a (* 1.5 pi)))
            (setq no (list x (- y h)))
          )
          ( (and (>= a (* 1.5 pi)) (< a (* 2 pi)))
            (setq no (list (+ x w) y))
          )
        )
        (setq ip (projpt2p1p2 no (car li) (cadr li)))
        (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
        (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
      )
    )
    (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* (mapcar '(lambda ( x ) (strcat (rtos (car x) 2 8) "," (rtos (cadr x) 2 8) "," (rtos (caddr x) 2 8) "," (rtos (nth 3 x) 2 8) "," (rtos (nth 4 x) 2 8) "," (rtos (nth 5 x) 2 8) "," (rtos (nth 6 x) 2 8))) (reverse ll)))
  )
  (setq ll (reverse ll))
  (setq al (reverse al))
  (setq nn (car (vl-sort (apply 'append ll) '(lambda ( a b ) (> (abs a) (abs b))))))
  (prompt "\nBiggest number is : ") (princ (rtos nn 2 20))
  (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)
  (setvar 'cmdecho cmde)
  (princ)
)

(defun c:savelltofile ( / f fn )
  (setq fn (getfiled "Select file you want to save values of global *ll* variable..." (strcat (getvar 'roamablerootprefix) "support\\ll-1") "txt" 1))
  (setq f (open fn "w"))
  (foreach l *ll*
    (write-line l f)
  )
  (close f)
  (princ)
)

(defun c:trimslsthand nil
  (repeat (length *ll*)
    (setq *slsthand* (cdr *slsthand*))
  )
  (princ)
)

(defun c:saveslsthandtofile ( / f fn )
  (setq fn (getfiled "Select file you want to save values of global *slsthand* variable..." (strcat (getvar 'roamablerootprefix) "support\\slsthand-1") "txt" 1))
  (setq f (open fn "w"))
  (foreach s *slsthand*
    (write-line (vl-prin1-to-string s) f)
  )
  (close f)
  (princ)
)

(defun c:loadslsthandfromfile ( / f fn s )
  (setq *slsthand* nil)
  (setq fn (getfiled "Select file you want to load values of global *slsthand* variable..." (strcat (getvar 'roamablerootprefix) "support\\") "txt" 16))
  (setq f (open fn "r"))
  (while (setq s (read-line f))
    (setq *slsthand* (cons (read s) *slsthand*))
  )
  (close f)
  (setq *slsthand* (reverse *slsthand*))
  (princ)
)

 

M.R.

 

Edited November 18, 2020 by marko_ribar

[marko_ribar]

I was brainstorming about this topic more, but unfortunately I only coded never ending stories... So my above posted code is for now the best, although it may give unreliable results with complex schemes for hatch generation...

First one is combination of big code (iteration) and short one (recursion), but as it looks for very big ol - point list of rectangles origins, it never finishes...

(defun c:savehatchfromstrcur ( / *error* trim0trailing trimlineto80chr acet-geom-ss-extents-accurate _do-events unit projpt2p1p2 intrecsang constolst car-sort cmde s boundary ch e minp maxp w h ww hh lil des fn f a x y no ip dx dy l v k ol oo pp ooo g lll ll al nn scf fuzz )

  (vl-load-com)

  (defun *error* ( m )
    (if cmde (setvar 'cmdecho cmde))
    (prompt "\nOther command functions after interruption and checking *ll* variable with !*ll* are :\n(c:savelltofile) ; (c:trimslsthand) ; (c:saveslsthandtofile) ; (c:loadslsthandfromfile)...")
    (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 _do-events nil ;;; Returns "" or T in essence
    (gc)
    (repeat 2 (vl-cmdf "_.DELAY" 0) (princ ""))
  ) ;;; remember to turn off cmdecho echoing DELAY; This prevents stalling CAD in loops - i.e. ESC will terminate routine preventing termination of CAD entirely

  (defun unit ( v / d )
    (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
      (mapcar '(lambda ( x ) (/ x d)) v)
    )
  )

  (defun projpt2p1p2 ( p p1 p2 / pp p1t ip )
    (setq pp (trans p 1 (unit (mapcar '- (trans p2 1 0) (trans p1 1 0)))))
    (setq p1t (trans p1 1 (unit (mapcar '- (trans p2 1 0) (trans p1 1 0)))))
    (setq ip (mapcar '+ '(0 0) (trans (list (car p1t) (cadr p1t) (caddr pp)) (unit (mapcar '- (trans p2 1 0) (trans p1 1 0))) 1)))
  )

  (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 constolst ( p a o w h oo / reclilst rec n q ) ;; p=(car li) ;; a=angle(car li)(cadr li) ;; o=starting boundary origin ;; w=width ;; h=height ;; oo=termination origin ;;; returns nil and defined ol variable

    (defun reclilst ( o w h )
      (list (list (mapcar '+ o '(0 0)) (mapcar '+ o (list w 0))) (list (mapcar '+ o (list w 0)) (mapcar '+ o (list w h))) (list (mapcar '+ o (list w h)) (mapcar '+ o (list 0 h))) (list (mapcar '+ o (list 0 h)) (mapcar '+ o '(0 0))))
    )

    (gc)
    (if (null lll)
      (setq rec (reclilst o w h))
      (setq rec (vl-remove-if '(lambda ( x ) (or (and (equal (car lll) (car x) 1e-6) (equal (cadr lll) (cadr x) 1e-6)) (and (equal (car lll) (cadr x) 1e-6) (equal (cadr lll) (car x) 1e-6)))) (reclilst o w h)))
    )
    (setq n (vl-position (setq lll (vl-some '(lambda ( x ) (if (setq q (inters p pp (car x) (cadr x))) x)) rec)) (reclilst o w h)))
    (cond
      ( (= n 0)
        (setq o (mapcar '+ o (list 0 (- h))))
      )
      ( (= n 1)
        (setq o (mapcar '+ o (list w 0)))
      )
      ( (= n 2)
        (setq o (mapcar '+ o (list 0 h)))
      )
      ( (= n 3)
        (setq o (mapcar '+ o (list (- w) 0)))
      )
    )
    (if (not (equal q oo 1e-6))
      (progn
        (setq ol (cons o ol))
        (constolst p a o w h oo)
      )
      (setq ol (cons o ol))
    )
  )

  (defun car-sort ( l f / removenth r k )

    (defun removenth ( l n / k )
      (setq k -1)
      (vl-remove-if '(lambda ( x ) (= (setq k (1+ k)) n)) l)
    )

    (setq k -1)
    (vl-some '(lambda ( a ) (setq k (1+ k)) (if (vl-every '(lambda ( x ) (apply f (list a x))) (removenth l k)) (setq r a))) l)
    r
  )
  ;;; (car-sort '(2 4 1 3 5 1) '<) => nil
  ;;; (car-sort '(2 4 1 3 5 1) '<=) => 1

  (setq *ll* nil)
  (initget "Yes No")
  (setq ch (getkword "\nDo you want to nil *slsthand* variable [Yes/No] <Yes> : "))
  (if (or (= ch "Yes") (null ch))
    (setq *slsthand* nil)
  )
  (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)
  (if (null *slsthand*)
    (setq *slsthand* (mapcar '(lambda ( x ) (cdr (assoc 5 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))))
  )
  (foreach hnd *slsthand*
    (setq e (handent hnd))
    (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 main fuzz factor <5e-10> : "))
  (if (null fuzz)
    (setq fuzz 5e-10)
  )
  (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 x (caar li) y (cadar li))
    (setq l (distance (car li) (cadr li)))
    (setq ip (intrecsang minp w h a))
    (setq v (mapcar '- ip minp))
    (setq k 0 loop t)
    (while loop
      (while (and (setq k (1+ k)) (if (zerop (rem k 5000)) (_do-events) T) (not (and (or (equal (/ (* k (abs (car v))) w) (fix (/ (* k (abs (car v))) w)) fuzz) (equal (/ (* k (abs (car v))) w) (fix (1+ (/ (* k (abs (car v))) w))) fuzz)) (or (equal (/ (* k (abs (cadr v))) h) (fix (/ (* k (abs (cadr v))) h)) fuzz) (equal (/ (* k (abs (cadr v))) h) (fix (1+ (/ (* k (abs (cadr v))) h))) fuzz))))))
      (setq ww (* w (fix (if (minusp (car v)) (- (/ (* k (car v)) w) 0.01) (+ (/ (* k (car v)) w) 0.01)))))
      (setq hh (* h (fix (if (minusp (cadr v)) (- (/ (* k (cadr v)) h) 0.01) (+ (/ (* k (cadr v)) h) 0.01)))))
      (setq oo (mapcar '+ minp (list ww hh)))
      (setq no (mapcar '+ oo (mapcar '- (car li) minp)))
      (if (equal a (angle (car li) no) 1e-14)
        (setq loop nil)
      )
    )
    (setq oo (mapcar '+ minp (mapcar '* v (list k k))))
    (setq g (- (- (distance minp oo) l)))
    (setq pp (polar (car li) a 1e+10))
    (constolst (car li) a minp w h oo)
    (setq ooo (car-sort ol '(lambda ( a b ) (<= (distance a (projpt2p1p2 a minp oo)) (distance b (projpt2p1p2 b minp oo))))))
    (setq no (mapcar '+ ooo (mapcar '- (car li) minp)))
    (setq ip (projpt2p1p2 no (car li) (cadr li)))
    (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
    (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
    (setq ol nil lll nil)
    (if (or (equal no ip 1e-6) (equal (car li) ip 1e-6))
      (progn
        (cond
          ( (and (>= a 0.0) (< a (* 0.5 pi)))
            (setq no (list x (+ y h)))
          )
          ( (and (>= a (* 0.5 pi)) (< a pi))
            (setq no (list (- x w) y))
          )
          ( (and (>= a pi) (< a (* 1.5 pi)))
            (setq no (list x (- y h)))
          )
          ( (and (>= a (* 1.5 pi)) (< a (* 2 pi)))
            (setq no (list (+ x w) y))
          )
        )
        (setq ip (projpt2p1p2 no (car li) (cadr li)))
        (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
        (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
      )
    )
    (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* (mapcar '(lambda ( x ) (strcat (rtos (car x) 2 8) "," (rtos (cadr x) 2 8) "," (rtos (caddr x) 2 8) "," (rtos (nth 3 x) 2 8) "," (rtos (nth 4 x) 2 8) "," (rtos (nth 5 x) 2 8) "," (rtos (nth 6 x) 2 8))) (reverse ll)))
  )
  (setq ll (reverse ll))
  (setq al (reverse al))
  (setq nn (car (vl-sort (apply 'append ll) '(lambda ( a b ) (> (abs a) (abs b))))))
  (prompt "\nBiggest number is : ") (princ (rtos nn 2 20))
  (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)
  (setvar 'cmdecho cmde)
  (princ)
)

(defun c:savelltofile ( / f fn )
  (setq fn (getfiled "Select file you want to save values of global *ll* variable..." (strcat (getvar 'roamablerootprefix) "support\\ll-1") "txt" 1))
  (setq f (open fn "w"))
  (foreach l *ll*
    (write-line l f)
  )
  (close f)
  (princ)
)

(defun c:trimslsthand nil
  (repeat (length *ll*)
    (setq *slsthand* (cdr *slsthand*))
  )
  (princ)
)

(defun c:saveslsthandtofile ( / f fn )
  (setq fn (getfiled "Select file you want to save values of global *slsthand* variable..." (strcat (getvar 'roamablerootprefix) "support\\slsthand-1") "txt" 1))
  (setq f (open fn "w"))
  (foreach s *slsthand*
    (write-line (vl-prin1-to-string s) f)
  )
  (close f)
  (princ)
)

(defun c:loadslsthandfromfile ( / f fn s )
  (setq *slsthand* nil)
  (setq fn (getfiled "Select file you want to load values of global *slsthand* variable..." (strcat (getvar 'roamablerootprefix) "support\\") "txt" 16))
  (setq f (open fn "r"))
  (while (setq s (read-line f))
    (setq *slsthand* (cons (read s) *slsthand*))
  )
  (close f)
  (setq *slsthand* (reverse *slsthand*))
  (princ)
)

And the second one - short code uses only (recursion), fuzz factors are hardcoded and I've put for comparison of int rec point and rec verts as 1e-8 in hope that it will find first closest point and terminate recursion... As you can see I removed some sub functions not needed...

(defun c:savehatchfromstrcur ( / *error* trim0trailing trimlineto80chr acet-geom-ss-extents-accurate unit projpt2p1p2 process cmde s boundary ch e minp maxp w h lil des fn f a x y no ip dx dy l ol oo pp ooo g lll ll al nn scf )

  (vl-load-com)

  (defun *error* ( m )
    (if cmde (setvar 'cmdecho cmde))
    (prompt "\nOther command functions after interruption and checking *ll* variable with !*ll* are :\n(c:savelltofile) ; (c:trimslsthand) ; (c:saveslsthandtofile) ; (c:loadslsthandfromfile)...")
    (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 unit ( v / d )
    (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
      (mapcar '(lambda ( x ) (/ x d)) v)
    )
  )

  (defun projpt2p1p2 ( p p1 p2 / pp p1t ip )
    (setq pp (trans p 1 (unit (mapcar '- (trans p2 1 0) (trans p1 1 0)))))
    (setq p1t (trans p1 1 (unit (mapcar '- (trans p2 1 0) (trans p1 1 0)))))
    (setq ip (mapcar '+ '(0 0) (trans (list (car p1t) (cadr p1t) (caddr pp)) (unit (mapcar '- (trans p2 1 0) (trans p1 1 0))) 1)))
  )

  (defun process ( p a o w h / reclilst rec recc n ) ;; p=(car li) ;; a=angle(car li)(cadr li) ;; o=starting boundary origin ;; w=width ;; h=height ;;; returns nil and defined ol variable and oo - termination origin

    (defun reclilst ( o w h )
      (list (list (mapcar '+ o '(0 0)) (mapcar '+ o (list w 0))) (list (mapcar '+ o (list w 0)) (mapcar '+ o (list w h))) (list (mapcar '+ o (list w h)) (mapcar '+ o (list 0 h))) (list (mapcar '+ o (list 0 h)) (mapcar '+ o '(0 0))))
    )

    (gc)
    (if (null lll)
      (setq rec (reclilst o w h))
      (setq rec (vl-remove-if '(lambda ( x ) (or (and (equal (car lll) (car x) 1e-6) (equal (cadr lll) (cadr x) 1e-6)) (and (equal (car lll) (cadr x) 1e-6) (equal (cadr lll) (car x) 1e-6)))) (reclilst o w h)))
    )
    (setq n (vl-position (setq lll (vl-some '(lambda ( x ) (if (setq oo (inters p pp (car x) (cadr x))) x)) rec)) (setq recc (reclilst o w h))))
    (cond
      ( (= n 0)
        (setq o (mapcar '+ o (list 0 (- h))))
      )
      ( (= n 1)
        (setq o (mapcar '+ o (list w 0)))
      )
      ( (= n 2)
        (setq o (mapcar '+ o (list 0 h)))
      )
      ( (= n 3)
        (setq o (mapcar '+ o (list (- w) 0)))
      )
    )
    (if ol
      (if (> (distance (car ol) (projpt2p1p2 (car ol) minp (polar minp a 1.0))) (distance o (projpt2p1p2 o minp (polar minp a 1.0))))
        (setq ol (cdr ol) ol (cons o ol))
      )
      (setq ol (cons o ol))
    )
    (if (not (vl-some '(lambda ( x ) (equal oo x 1e-8)) (append (mapcar 'car recc) (mapcar 'car (reclilst o w h)))))
      (process p a o w h)
    )
  )

  (setq *ll* nil)
  (initget "Yes No")
  (setq ch (getkword "\nDo you want to nil *slsthand* variable [Yes/No] <Yes> : "))
  (if (or (= ch "Yes") (null ch))
    (setq *slsthand* nil)
  )
  (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)
  (if (null *slsthand*)
    (setq *slsthand* (mapcar '(lambda ( x ) (cdr (assoc 5 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))))
  )
  (foreach hnd *slsthand*
    (setq e (handent hnd))
    (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 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 x (caar li) y (cadar li))
    (setq l (distance (car li) (cadr li)))
    (setq pp (polar (car li) a 1e+10))
    (process (car li) a minp w h)
    (setq g (- (- (distance minp oo) l)))
    (setq ooo (car ol))
    (setq no (mapcar '+ ooo (mapcar '- (car li) minp)))
    (setq ip (projpt2p1p2 no (car li) (cadr li)))
    (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
    (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
    (setq ol nil lll nil oo nil)
    (if (or (equal no ip 1e-6) (equal (car li) ip 1e-6))
      (progn
        (cond
          ( (and (>= a 0.0) (< a (* 0.5 pi)))
            (setq no (list x (+ y h)))
          )
          ( (and (>= a (* 0.5 pi)) (< a pi))
            (setq no (list (- x w) y))
          )
          ( (and (>= a pi) (< a (* 1.5 pi)))
            (setq no (list x (- y h)))
          )
          ( (and (>= a (* 1.5 pi)) (< a (* 2 pi)))
            (setq no (list (+ x w) y))
          )
        )
        (setq ip (projpt2p1p2 no (car li) (cadr li)))
        (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
        (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
      )
    )
    (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* (mapcar '(lambda ( x ) (strcat (rtos (car x) 2 8) "," (rtos (cadr x) 2 8) "," (rtos (caddr x) 2 8) "," (rtos (nth 3 x) 2 8) "," (rtos (nth 4 x) 2 8) "," (rtos (nth 5 x) 2 8) "," (rtos (nth 6 x) 2 8))) (reverse ll)))
  )
  (setq ll (reverse ll))
  (setq al (reverse al))
  (setq nn (car (vl-sort (apply 'append ll) '(lambda ( a b ) (> (abs a) (abs b))))))
  (prompt "\nBiggest number is : ") (princ (rtos nn 2 20))
  (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)
  (setvar 'cmdecho cmde)
  (princ)
)

(defun c:savelltofile ( / f fn )
  (setq fn (getfiled "Select file you want to save values of global *ll* variable..." (strcat (getvar 'roamablerootprefix) "support\\ll-1") "txt" 1))
  (setq f (open fn "w"))
  (foreach l *ll*
    (write-line l f)
  )
  (close f)
  (princ)
)

(defun c:trimslsthand nil
  (repeat (length *ll*)
    (setq *slsthand* (cdr *slsthand*))
  )
  (princ)
)

(defun c:saveslsthandtofile ( / f fn )
  (setq fn (getfiled "Select file you want to save values of global *slsthand* variable..." (strcat (getvar 'roamablerootprefix) "support\\slsthand-1") "txt" 1))
  (setq f (open fn "w"))
  (foreach s *slsthand*
    (write-line (vl-prin1-to-string s) f)
  )
  (close f)
  (princ)
)

(defun c:loadslsthandfromfile ( / f fn s )
  (setq *slsthand* nil)
  (setq fn (getfiled "Select file you want to load values of global *slsthand* variable..." (strcat (getvar 'roamablerootprefix) "support\\") "txt" 16))
  (setq f (open fn "r"))
  (while (setq s (read-line f))
    (setq *slsthand* (cons (read s) *slsthand*))
  )
  (close f)
  (setq *slsthand* (reverse *slsthand*))
  (princ)
)

So if someone find those codes still useful and finds better ways to approach the problem, we'll be glad if he/she would reply and post his/her findings...

Regards from me and best wishes in your coding, M.R.

Edited November 18, 2020 by marko_ribar

[marko_ribar]

My recursion (last code) worked for me as I mod. it slightly... But now it seems that my method of finding dx and dy is wrong... Routine did find dy minimal - that's for what is coded, but result was unexpected when hatched... So there is something what I/we don't quite know... In attachment as also in picture you can see buggy result...

 

Regards, M.R.

 

 

mr-hat.zip

Edited May 10, 2020 by marko_ribar

[marko_ribar]

Neither is good for checking of minimal delta angle... Result is almost the same as with checking for min dy... Only thing is that this version is faster then previous, but still no luck...

 

(defun c:savehatchfromstrcur ( / *error* trim0trailing trimlineto80chr acet-geom-ss-extents-accurate unit projpt2p1p2 process cmde s boundary ch e minp maxp w h lil des fn f a x y no ip dx dy l ol oo pp ooo g lll ll al nn scf )

  (vl-load-com)

  (defun *error* ( m )
    (if cmde (setvar 'cmdecho cmde))
    (prompt "\nOther command functions after interruption and checking *ll* variable with !*ll* are :\n(c:savelltofile) ; (c:trimslsthand) ; (c:saveslsthandtofile) ; (c:loadslsthandfromfile)...")
    (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 unit ( v / d )
    (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
      (mapcar '(lambda ( x ) (/ x d)) v)
    )
  )

  (defun projpt2p1p2 ( p p1 p2 / pp p1t ip )
    (setq pp (trans p 1 (unit (mapcar '- (trans p2 1 0) (trans p1 1 0)))))
    (setq p1t (trans p1 1 (unit (mapcar '- (trans p2 1 0) (trans p1 1 0)))))
    (setq ip (mapcar '+ '(0 0) (trans (list (car p1t) (cadr p1t) (caddr pp)) (unit (mapcar '- (trans p2 1 0) (trans p1 1 0))) 1)))
  )

  (defun process ( p a o w h / reclilst rec recc n ) ;; p=(car li) ;; a=angle(car li)(cadr li) ;; o=starting boundary origin ;; w=width ;; h=height ;;; returns nil and defined ol variable and oo - termination origin

    (defun reclilst ( o w h )
      (list (list (mapcar '+ o '(0 0)) (mapcar '+ o (list w 0))) (list (mapcar '+ o (list w 0)) (mapcar '+ o (list w h))) (list (mapcar '+ o (list w h)) (mapcar '+ o (list 0 h))) (list (mapcar '+ o (list 0 h)) (mapcar '+ o '(0 0))))
    )

    (gc)
    (if (null lll)
      (setq rec (reclilst o w h))
      (setq rec (vl-remove-if '(lambda ( x ) (or (and (equal (car lll) (car x) 1e-6) (equal (cadr lll) (cadr x) 1e-6)) (and (equal (car lll) (cadr x) 1e-6) (equal (cadr lll) (car x) 1e-6)))) (reclilst o w h)))
    )
    (setq n (vl-position (setq lll (vl-some '(lambda ( x ) (if (setq oo (inters p pp (car x) (cadr x))) x)) rec)) (setq recc (reclilst o w h))))
    (cond
      ( (= n 0)
        (setq o (mapcar '+ o (list 0 (- h))))
      )
      ( (= n 1)
        (setq o (mapcar '+ o (list w 0)))
      )
      ( (= n 2)
        (setq o (mapcar '+ o (list 0 h)))
      )
      ( (= n 3)
        (setq o (mapcar '+ o (list (- w) 0)))
      )
    )
    (if ol
      (if (> 
            (abs (cond ( (and (> 0.0 a (* 0.5 pi)) (> (* 1.5 pi) (angle minp (car ol)) (* 2 pi))) (- (angle minp (car ol)) (+ a pi pi)) ) ( (and (> 0.0 (angle minp (car ol)) (* 0.5 pi)) (> (* 1.5 pi) a (* 2 pi))) (- (+ (angle minp (car ol)) pi pi) a) ) ( t (- (angle minp (car ol)) a) )))
            (abs (cond ( (and (> 0.0 a (* 0.5 pi)) (> (* 1.5 pi) (angle minp o) (* 2 pi))) (- (angle minp o) (+ a pi pi)) ) ( (and (> 0.0 (angle minp o) (* 0.5 pi)) (> (* 1.5 pi) a (* 2 pi))) (- (+ (angle minp o) pi pi) a) ) ( t (- (angle minp o) a) )))
          )
        (setq ol (cdr ol) ol (cons o ol))
      )
      (setq ol (cons o ol))
    )
    (if (not (vl-some '(lambda ( x ) (equal oo x 1e-8)) (append (mapcar 'car recc) (mapcar 'car (reclilst o w h)))))
      (process p a o w h)
    )
  )

  (setq *ll* nil)
  (initget "Yes No")
  (setq ch (getkword "\nDo you want to nil *slsthand* variable [Yes/No] <Yes> : "))
  (if (or (= ch "Yes") (null ch))
    (setq *slsthand* nil)
  )
  (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)
  (if (null *slsthand*)
    (setq *slsthand* (mapcar '(lambda ( x ) (cdr (assoc 5 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))))
  )
  (foreach hnd *slsthand*
    (setq e (handent hnd))
    (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 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 x (caar li) y (cadar li))
    (setq l (distance (car li) (cadr li)))
    (setq pp (polar (car li) a 1e+10))
    (process (car li) a minp w h)
    (setq g (- (- (distance minp oo) l)))
    (setq ooo (car ol))
    (setq no (mapcar '+ ooo (mapcar '- (car li) minp)))
    (setq ip (projpt2p1p2 no (car li) (cadr li)))
    (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
    (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
    (setq ol nil lll nil oo nil)
    (if (or (equal no ip 1e-6) (equal (car li) ip 1e-6))
      (progn
        (cond
          ( (and (>= a 0.0) (< a (* 0.5 pi)))
            (setq no (list x (+ y h)))
          )
          ( (and (>= a (* 0.5 pi)) (< a pi))
            (setq no (list (- x w) y))
          )
          ( (and (>= a pi) (< a (* 1.5 pi)))
            (setq no (list x (- y h)))
          )
          ( (and (>= a (* 1.5 pi)) (< a (* 2 pi)))
            (setq no (list (+ x w) y))
          )
        )
        (setq ip (projpt2p1p2 no (car li) (cadr li)))
        (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
        (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
      )
    )
    (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* (mapcar '(lambda ( x ) (strcat (rtos (car x) 2 8) "," (rtos (cadr x) 2 8) "," (rtos (caddr x) 2 8) "," (rtos (nth 3 x) 2 8) "," (rtos (nth 4 x) 2 8) "," (rtos (nth 5 x) 2 8) "," (rtos (nth 6 x) 2 8))) (reverse ll)))
  )
  (setq ll (reverse ll))
  (setq al (reverse al))
  (setq nn (car (vl-sort (apply 'append ll) '(lambda ( a b ) (> (abs a) (abs b))))))
  (prompt "\nBiggest number is : ") (princ (rtos nn 2 20))
  (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)
  (setvar 'cmdecho cmde)
  (princ)
)

(defun c:savelltofile ( / f fn )
  (setq fn (getfiled "Select file you want to save values of global *ll* variable..." (strcat (getvar 'roamablerootprefix) "support\\ll-1") "txt" 1))
  (setq f (open fn "w"))
  (foreach l *ll*
    (write-line l f)
  )
  (close f)
  (princ)
)

(defun c:trimslsthand nil
  (repeat (length *ll*)
    (setq *slsthand* (cdr *slsthand*))
  )
  (princ)
)

(defun c:saveslsthandtofile ( / f fn )
  (setq fn (getfiled "Select file you want to save values of global *slsthand* variable..." (strcat (getvar 'roamablerootprefix) "support\\slsthand-1") "txt" 1))
  (setq f (open fn "w"))
  (foreach s *slsthand*
    (write-line (vl-prin1-to-string s) f)
  )
  (close f)
  (princ)
)

(defun c:loadslsthandfromfile ( / f fn s )
  (setq *slsthand* nil)
  (setq fn (getfiled "Select file you want to load values of global *slsthand* variable..." (strcat (getvar 'roamablerootprefix) "support\\") "txt" 16))
  (setq f (open fn "r"))
  (while (setq s (read-line f))
    (setq *slsthand* (cons (read s) *slsthand*))
  )
  (close f)
  (setq *slsthand* (reverse *slsthand*))
  (princ)
)

M.R.

Edited November 18, 2020 by marko_ribar

[marko_ribar]

My latest findings are telling that problem with those codes - recursion is precision... Min dy should work, but when precision is greater (1e-8 => 5e-10), then routine goes deeper, but then is so slow that you can't wait to finish all operations during recursion... So still my best shot is firstly posted code with (while) looping... But yes, sometimes it isn't fully precise because of loosing speed (some checking is deliberately omitted)... Recursion version checks all...

Edited May 10, 2020 by marko_ribar

[marko_ribar]

I've decided to improve more my main routine : https://www.cadtutor.net/forum/topic/70417-make-pat-files/?do=findComment&comment=565434

I added few more options for checking by delta angle and also I shortened main order of integer list if it was chosen secondary fuzz for which to check - else it can perform complete checking by all integer list gathered until main fuzz stops looping - rectangle origin is very close to XLINE angle of reference line with origin at minp... And that was all fine until I discovered that there were numerous lacks in my coding... I started calculation, and PC worked all until I discovered that LISP entered never ending loop... So I lost el. energy and time and only moments ago I finally cleaned it... So if you plan to use it, now is the time to copy+paste code tag to your *.lsp...

Sorry for delay, but I didn't noticed bugs earlier... If there is still something wrong, and you discovered where was the bug, please help us to make it better as much as possible...

I am using this routine now seriously and I don't want to think that it may fail at some point - AutoCAD calculated fine, but slow and BricsCAD fails, but I don't have too complex drawings for now so I am satisfied with AutoCAD job... Some results ACAD though can't present, but BricsCAD can, so both programs are useful in some ways and I hope you'll use routine well in your workflow...

Regards, stay well, M.R.

[marko_ribar]

I've found one more lack... Now you can copy+paste the code...

M.R.

[marko_ribar]

I've decided to add 2 more routines that are IMHO very close to optimum for custom hatch pattern generation... They are *-cross.lsp and *-uprows.lsp... The second one is the one I am really proud of - only lack is it's not going into infinity with rows and there was a problem with horizontal lines which had to go infinitely, so there can be some lacks in interpretations, but I suggest then - avoid horizontal lines if you can in custom sample for generation of *.pat file...

 

(defun c:savehatchrectbound-cross ( / *error* trim0trailing trimlineto80chr acet-geom-ss-extents-accurate unit projpt2p1p2 intrecsang cmde s boundary ch minp maxp w h ww hh lil fuzz des fn a x y no ip dx dy l v k ooo g ll f al scf )

  (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 unit ( v / d )
    (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
      (mapcar '(lambda ( x ) (/ x d)) v)
    )
  )

  (defun projpt2p1p2 ( p p1 p2 / pp p1t ip )
    (setq pp (trans p 1 (unit (mapcar '- (trans p2 1 0) (trans p1 1 0)))))
    (setq p1t (trans p1 1 (unit (mapcar '- (trans p2 1 0) (trans p1 1 0)))))
    (setq ip (mapcar '+ '(0 0) (trans (list (car p1t) (cadr p1t) (caddr pp)) (unit (mapcar '- (trans p2 1 0) (trans p1 1 0))) 1)))
  )

  (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)))
  )

  (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 main fuzz factor <5e-10> : "))
  (if (null fuzz)
    (setq fuzz 5e-10)
  )
  (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))
  (initget 1 "1 3 5")
  (setq ch (getkword "\nChoose option - cross [1. 1x1 row-column/3. 3x3 row-column/5. 5x5 row-column] : "))
  (foreach li lil
    (setq a (angle (car li) (cadr li)))
    (setq l (distance (car li) (cadr li)))
    (cond
      ( (or (equal a 0.0 1e-6) (equal a (* 2 pi) 1e-6) (equal a pi 1e-6))
        (setq x (caar li) y (cadar li) dx 0.0 dy h g (- (- w l)))
        (setq ll (cons (list (cvunit a "radian" "degree") x y dx dy l g) ll))
        (setq al (cons (cvunit a "radian" "degree") al))
      )
      ( (or (equal a (* 0.5 pi) 1e-6) (equal a (* 1.5 pi) 1e-6))
        (setq x (caar li) y (cadar li) dx 0.0 dy w g (- (- h l)))
        (setq ll (cons (list (cvunit a "radian" "degree") x y dx dy l g) ll))
        (setq al (cons (cvunit a "radian" "degree") al))
      )
      ( t
        (setq ip (intrecsang minp w h a))
        (setq v (mapcar '- ip minp))
        (setq k 0)
        (while (and (setq k (1+ k)) (not (and (or (equal (/ (* k (abs (car v))) w) (fix (/ (* k (abs (car v))) w)) fuzz) (equal (/ (* k (abs (car v))) w) (fix (1+ (/ (* k (abs (car v))) w))) fuzz)) (or (equal (/ (* k (abs (cadr v))) h) (fix (/ (* k (abs (cadr v))) h)) fuzz) (equal (/ (* k (abs (cadr v))) h) (fix (1+ (/ (* k (abs (cadr v))) h))) fuzz))))))
        (setq ooo (mapcar '+ minp (mapcar '* v (list k k))))
        (setq g (- (- (distance minp ooo) l)))
        (foreach qq (mapcar '(lambda ( gg ) (mapcar '+ (car li) (mapcar '* (list w h) (list gg gg)))) (cond ((= ch "1") (list 0.0)) ((= ch "3") (list -1.0 0.0 1.0)) ((= ch "5") (list -2.0 -1.0 0.0 1.0 2.0))))
          (setq x (car qq) y (cadr qq))
          (foreach q (list (list w 0.0) (list 0.0 h))
            (setq no (mapcar '+ qq q))
            (setq ip (projpt2p1p2 no qq (mapcar '+ qq (mapcar '- (cadr li) (car li)))))
            (setq dx (if (equal (angle qq ip) a 1e-6) (distance qq ip) (- (distance qq ip))))
            (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
            (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)
  (setvar 'cmdecho cmde)
  (princ)
)

(defun c:savehatchrectbound-uprows ( / *error* trim0trailing trimlineto80chr acet-geom-ss-extents-accurate unit projpt2p1p2 cmde s boundary ch minp maxp w h ww hh lil des fn a x y no ip dx dy l v k g ll f al scf )

  (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 unit ( v / d )
    (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
      (mapcar '(lambda ( x ) (/ x d)) v)
    )
  )

  (defun projpt2p1p2 ( p p1 p2 / pp p1t ip )
    (setq pp (trans p 1 (unit (mapcar '- (trans p2 1 0) (trans p1 1 0)))))
    (setq p1t (trans p1 1 (unit (mapcar '- (trans p2 1 0) (trans p1 1 0)))))
    (setq ip (mapcar '+ '(0 0) (trans (list (car p1t) (cadr p1t) (caddr pp)) (unit (mapcar '- (trans p2 1 0) (trans p1 1 0))) 1)))
  )

  (setq cmde (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (alert "SAVE DWG BEFORE APPLYING THIS ROUTINE...\nDraw boundary rectangle and hatching geometry (lines) inside boundary. IF YOU HAVE STRAIGHT POLYLINES INSIDE BOUNDARY, YOU MUST EXPLODE THEM TO LINES AND RESTART ROUTINE...")
  (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 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))
  (initget 7)
  (setq ch (getint "\nHow many rows to multiply up direction : "))
  (foreach li lil
    (setq a (angle (car li) (cadr li)))
    (setq l (distance (car li) (cadr li)))
    (if (or (equal a 0.0 1e-6) (equal a (* 2 pi) 1e-6) (equal a pi 1e-6))
      (progn
        (setq x (caar li) y (cadar li) dx 0.0 dy h g (- (- w l)))
        (setq ll (cons (list (cvunit a "radian" "degree") x y dx dy l g) ll))
        (setq al (cons (cvunit a "radian" "degree") al))
      )
      (progn
        (setq k -1)
        (setq g -9999999)
        (repeat ch
          (setq x (caar li) y (+ (cadar li) (* (setq k (1+ k)) h)))
          (setq no (mapcar '+ (car li) (list w 0.0)))
          (setq ip (projpt2p1p2 no (car li) (cadr li)))
          (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
          (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
          (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)
  (setvar 'cmdecho cmde)
  (princ)
)

Regards, M.R.

I hope you can find them useful...

Edited November 18, 2020 by marko_ribar

[marko_ribar]

FWIW. Now I am using this versions... I had to add small deviations to avoid horizontal and vertical lines issues... So now everything should be as expected no matter what samples are used for pattern generation...

 

(defun c:savehatchrectbound-cross ( / *error* trim0trailing trimlineto80chr acet-geom-ss-extents-accurate unit projpt2p1p2 intrecsang cmde s boundary ch minp maxp w h ww hh lil fuzz des fn a li x y no ip dx dy l v k ooo g ll f al scf )

  (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 unit ( v / d )
    (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
      (mapcar '(lambda ( x ) (/ x d)) v)
    )
  )

  (defun projpt2p1p2 ( p p1 p2 / pp p1t ip )
    (setq pp (trans p 1 (unit (mapcar '- (trans p2 1 0) (trans p1 1 0)))))
    (setq p1t (trans p1 1 (unit (mapcar '- (trans p2 1 0) (trans p1 1 0)))))
    (setq ip (mapcar '+ '(0 0) (trans (list (car p1t) (cadr p1t) (caddr pp)) (unit (mapcar '- (trans p2 1 0) (trans p1 1 0))) 1)))
  )

  (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)))
  )

  (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 main fuzz factor <5e-10> : "))
  (if (null fuzz)
    (setq fuzz 5e-10)
  )
  (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))
  (initget 1 "1 3 5")
  (setq ch (getkword "\nChoose option - cross [1. 1x1 row-column/3. 3x3 row-column/5. 5x5 row-column] : "))
  (foreach li lil
    (setq a (angle (car li) (cadr li)))
    (setq l (distance (car li) (cadr li)))
    (if (or (equal a 0.0 1e-6) (equal a (* 2 pi) 1e-6) (equal a pi 1e-6) (equal a (* 0.5 pi) 1e-6) (equal a (* 1.5 pi) 1e-6))
      (progn
        (setq a (+ a (cvunit 0.1 "degree" "radian")))
        (setq li (list (car li) (polar (car li) a (setq l (/ l (cos (cvunit 0.1 "degree" "radian")))))))
        (setq g -99999999)
        (setq ip (intrecsang minp w h a))
      )
      (progn
        (setq ip (intrecsang minp w h a))
        (setq v (mapcar '- ip minp))
        (setq k 0)
        (while (and (setq k (1+ k)) (not (and (or (equal (/ (* k (abs (car v))) w) (fix (/ (* k (abs (car v))) w)) fuzz) (equal (/ (* k (abs (car v))) w) (fix (1+ (/ (* k (abs (car v))) w))) fuzz)) (or (equal (/ (* k (abs (cadr v))) h) (fix (/ (* k (abs (cadr v))) h)) fuzz) (equal (/ (* k (abs (cadr v))) h) (fix (1+ (/ (* k (abs (cadr v))) h))) fuzz))))))
        (setq ooo (mapcar '+ minp (mapcar '* v (list k k))))
        (setq g (- (- (distance minp ooo) l)))
      )
    )
    (foreach qq (mapcar '(lambda ( gg ) (mapcar '+ (car li) (mapcar '* (list w h) (list gg gg)))) (cond ((= ch "1") (list 0.0)) ((= ch "3") (list -1.0 0.0 1.0)) ((= ch "5") (list -2.0 -1.0 0.0 1.0 2.0))))
      (setq x (car qq) y (cadr qq))
      (foreach q (list (list w 0.0) (list 0.0 h))
        (setq no (mapcar '+ qq q))
        (setq ip (projpt2p1p2 no qq (mapcar '+ qq (mapcar '- (cadr li) (car li)))))
        (setq dx (if (equal (angle qq ip) a 1e-6) (distance qq ip) (- (distance qq ip))))
        (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
        (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)
)

(defun c:savehatchrectbound-uprows ( / *error* trim0trailing trimlineto80chr acet-geom-ss-extents-accurate unit projpt2p1p2 cmde s boundary ch minp maxp w h ww hh lil des fn a li x y no ip dx dy l v k g ll f al scf )

  (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 unit ( v / d )
    (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
      (mapcar '(lambda ( x ) (/ x d)) v)
    )
  )

  (defun projpt2p1p2 ( p p1 p2 / pp p1t ip )
    (setq pp (trans p 1 (unit (mapcar '- (trans p2 1 0) (trans p1 1 0)))))
    (setq p1t (trans p1 1 (unit (mapcar '- (trans p2 1 0) (trans p1 1 0)))))
    (setq ip (mapcar '+ '(0 0) (trans (list (car p1t) (cadr p1t) (caddr pp)) (unit (mapcar '- (trans p2 1 0) (trans p1 1 0))) 1)))
  )

  (setq cmde (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (alert "SAVE DWG BEFORE APPLYING THIS ROUTINE...\nDraw boundary rectangle and hatching geometry (lines) inside boundary. IF YOU HAVE STRAIGHT POLYLINES INSIDE BOUNDARY, YOU MUST EXPLODE THEM TO LINES AND RESTART ROUTINE...")
  (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 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))
  (initget 7)
  (setq ch (getint "\nHow many rows to multiply up direction : "))
  (foreach li lil
    (setq a (angle (car li) (cadr li)))
    (setq l (distance (car li) (cadr li)))
    (if (or (equal a 0.0 1e-6) (equal a (* 2 pi) 1e-6) (equal a pi 1e-6))
      (progn
        (setq a (+ a (cvunit 0.1 "degree" "radian")))
        (setq li (list (car li) (polar (car li) a (setq l (/ l (cos (cvunit 0.1 "degree" "radian")))))))
      )
    )
    (setq k -1)
    (setq g -99999999)
    (repeat ch
      (setq x (caar li) y (+ (cadar li) (* (setq k (1+ k)) h)))
      (setq no (mapcar '+ (car li) (list w 0.0)))
      (setq ip (projpt2p1p2 no (car li) (cadr li)))
      (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
      (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
      (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)
)

So long from me...

Hope you'll use those 2 routines well in your working adventures...

Regards, M.R.

(Stay well...)

Edited November 18, 2020 by marko_ribar

[marko_ribar]

Hi, its me again...

I tried to improve my version from top of this page, but still it's good only for simple examples, for more complex it may even fail and break... Nevertheless, I'll post my latest version here - now I am using this instead of top page code... And yes there must be no interuptions with ESC - this works like normal routine... I've hardcoded fuzz of 1e-3, but sometimes you'll need bigger number like 0.1, or even up to 5.0 and sometimes it's good as is - haven't experienced when smaller value is needed...

 

(defun c:savehatchfromstrcur ( / *error* trim0trailing trimlineto80chr car-sort acet-geom-ss-extents-accurate intrecsang detk genptlst cmde s boundary ch minp maxp w h lil fuzz des fn a x y ip dx dy l v k oo ooo g ll f al scf ww hh pl p d )

  (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 car-sort ( lst cmp / rtn )
    (setq rtn (car lst))
    (foreach itm (cdr lst)
      (if (apply cmp (list itm rtn))
        (setq rtn itm)
      )
    )
    rtn
  )

  (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 ( v w h fuzz / vx vy k kk )
    (setq vx (car v) vy (cadr v))
    (cond
      ( (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)
        (setq kk 0)
        (if (minusp vx)
          (while (not (or (equal (rem (abs (- (cadr (inters (mapcar '+ minp (list (* w (setq kk (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))))
          (while (not (or (equal (rem (abs (- (cadr (inters (mapcar '+ minp (list (* w (setq kk (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)
        (setq kk 0)
        (if (minusp vy)
          (while (not (or (equal (rem (abs (- (car (inters (mapcar '+ minp (list 0.0 (* h (setq kk (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))))
          (while (not (or (equal (rem (abs (- (car (inters (mapcar '+ minp (list 0.0 (* h (setq kk (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))))
      )
    )
    k
  )

  (defun genptlst ( o oo a w h ww hh d / r c p pl )
    (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)) (< (+ (distance o p) (distance p oo)) d))
              (setq pl (cons p pl))
            )
          )
        )
      )
      ( (< (* 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)) (< (+ (distance o p) (distance p oo)) d))
              (setq pl (cons p pl))
            )
          )
        )
      )
      ( (< 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)) (< (+ (distance o p) (distance p oo)) d))
              (setq pl (cons p pl))
            )
          )
        )
      )
      ( 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)) (< (+ (distance o p) (distance p oo)) d))
              (setq pl (cons p pl))
            )
          )
        )
      )
    )
    pl
  )

  (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 <1e-3> : "))
  (if (null fuzz)
    (setq fuzz 1e-3)
  )
  (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 k (detk v w h fuzz))
    (gc)
    (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)))
    (setq ooo (mapcar '+ minp (mapcar '* v (list k k))))
    (setq g (- (- (distance minp ooo) l)))
    (entmake (list '(0 . "LINE") (cons 10 (car li)) (cons 11 (setq oo (polar (car li) a (+ l (- g)))))))
    (setq d (* 1.5 (distance (car li) oo)))
    (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)))
      )
      ( t
        (setq pl (genptlst (car li) oo a w h ww hh d))
        (gc)
        (setq p (car-sort pl '(lambda ( a b ) (< (distance a (vlax-curve-getclosestpointto (entlast) a)) (distance b (vlax-curve-getclosestpointto (entlast) b))))))
      )
    )
    (setq ip (vlax-curve-getclosestpointto (entlast) p))
    (entdel (entlast))
    (setq dx (distance (car li) ip) dy (if (equal (rem (+ a (* 0.5 pi)) (* 2.0 pi)) (angle ip p) 1e-6) (distance ip p) (- (distance ip p))))
    ;(setq dx (+ (* h ww (cos (- a (* 0.5 pi)))) (* w hh (sin (- a (* 0.5 pi))))) dy (+ (* h ww (cos a)) (* w hh (sin a))))
    (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)
)

Regards,

HTH.

M.R.

Edited November 18, 2020 by marko_ribar

[marko_ribar]

Here is my revision of last posted code... Now crash under BricsCAD is very rare, but when small fuzz is specified CAD may encounter much more points for checking for calculating dx and dy - it won't crash as now there is no list making and checking is performed on the fly, but amount of points that are to be expected may be over 1e+6 - millions if not even more... So it can be terribly slow, but precision is better when small fuzz is specified... On simple examples it's good, but for more complex there is no other way than wait to finish calculations... And all this at what cost - just to make *.pat smaller and inf rows and inf columns... FWIW my version *-uprows.lsp is doing this in matter of seconds - precise, but bigger *.pat and limited number of rows... Anyway here is my revision, so who want it may use it, but be warned - I explained the problem... Number of checking points can't be reduced - I don't know how to do it - HatchMaker.lsp from 2005 is doing this on square 1.0x1.0, but I am afraid I don't know how to implement such algorithm on my very custom example w x h rectangular boundary...

 

(defun c:savehatchfromstrcur ( / *error* trim0trailing trimlineto80chr acet-geom-ss-extents-accurate intrecsang detk getp cmde s boundary ch minp maxp w h lil fuzz fuz fuzzz des fn a x y p ip dx dy l v k k1 k2 ooo g ll f al scf ww hh )

  (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
      ( (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 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-8> : "))
  (if (null fuzz)
    (setq fuzz 1e-8)
  )
  (initget 6)
  (setq fuz (getreal "\nSpecify fuzz factor for determining dx and dy - little bigger fuzz - must be smaller than 0.05 - <5e-5> : "))
  (if (null fuz)
    (setq fuz 5e-5)
  )
  (setq fuzzz fuz)
  (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 fuz fuzzz)
    (setq k1 (detk minp v w h fuz 0))
    (gc)
    (setq k2 (detk minp v w h fuzz (if (minusp (cadr k1)) (1+ (cadr k1)) (1- (cadr k1)))))
    (gc)
    (while (and (= (car k1) (car k2)) (< fuz 0.05))
      (setq k1 (detk minp v w h (setq fuz (* 10.0 fuz)) 0))
      (gc)
    )
    (setq ooo (mapcar '+ minp (mapcar '* v (list (car k2) (car k2)))))
    (setq g (- (- (distance minp ooo) l)))
    (setq ww (fix (/ (+ (abs (car (mapcar '* v (list (car k1) (car k1))))) 1e-2) w)) hh (fix (/ (+ (abs (cadr (mapcar '* v (list (car k1) (car k1))))) 1e-2) h)))
    (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 (/= (car k1) (car k2)) (>= fuz 0.05))
        (cond
          ( (> (car k2) 1000)
            (if (< (car k1) 10)
              (progn
                (setq k1 (list 10 (cadr k1)))
                (setq ww (fix (/ (+ (abs (car (mapcar '* v (list (car k1) (car k1))))) 1e-2) w)) hh (fix (/ (+ (abs (cadr (mapcar '* v (list (car k1) (car k1))))) 1e-2) h)))
              )
            )
            (setq p (getp (car li) a w h ww hh))
            (gc)
          )
          ( t
            (setq ww (fix (/ (+ (abs (car (mapcar '* v (list (car k2) (car k2))))) 1e-2) w)) hh (fix (/ (+ (abs (cadr (mapcar '* v (list (car k2) (car k2))))) 1e-2) h)))
            (setq p (getp (car li) a w h ww hh))
            (gc)
          )
        )
        (if (null p)
          (progn
            (setq ww (fix (/ (+ (abs (car (mapcar '* v (list (car k2) (car k2))))) 1e-2) w)) hh (fix (/ (+ (abs (cadr (mapcar '* v (list (car k2) (car k2))))) 1e-2) h)))
            (setq p (getp (car li) a w h ww hh))
            (gc)
          )
        )
      )
      ( t
        (if (and (< (car k1) 10) (>= (car k2) 10))
          (progn
            (setq k1 (list 10 (cadr k1)))
            (setq ww (fix (/ (+ (abs (car (mapcar '* v (list (car k1) (car k1))))) 1e-2) w)) hh (fix (/ (+ (abs (cadr (mapcar '* v (list (car k1) (car k1))))) 1e-2) h)))
          )
        )
        (setq p (getp (car li) a w h ww hh))
        (gc)
      )
    )
    (setq ip (inters p (polar p (+ a (* 0.5 pi)) 1.0) (car li) (polar (car li) a 1.0) nil))
    (setq dx (distance (car li) ip) dy (if (equal (rem (+ a (* 0.5 pi)) (* 2.0 pi)) (angle ip p) 1e-6) (distance ip p) (- (distance ip p))))
    ;(setq dx (+ (* h ww (cos (- a (* 0.5 pi)))) (* w hh (sin (- a (* 0.5 pi))))) dy (+ (* h ww (cos a)) (* w hh (sin a))))
    (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)
)

 

Edited November 18, 2020 by marko_ribar
code changed a little...

[marko_ribar]

Just to inform that I've finally updated my revisions of last posted code and as a gift I am attaching my *.pat file generated with this routine... Note that ACAD generated correctly *.pat and BricsCAD had lacks, but all in all it was just slightly slower in ACAD...

 

Regards, M.R.

sup.pat

[marko_ribar]

Here is my latest version that I am using also... It should be faster than lastly posted one - there is no grid points checking - that's why it's better and faster... Still sometimes ACAD can't display hatch even if *.pat is IMHO correct... I'll attach my version of *.pat file generated with this version on more precise superman-logo sample DWG... I think that this is as far as I can write to be as much applicable possible by using my method of smallest dy...

 

(defun c:savehatchfromstrcur ( / *error* trim0trailing trimlineto80chr acet-geom-ss-extents-accurate intrecsang detk detdxdy getp cmde s boundary ch minp maxp w h lil fuzz des fn a x y p ip dx dy l v k i ooo g ll f al scf ww hh dxdy dyy )

  (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))))
      )
    )
    k
  )

  (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 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 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 k (detk minp v w h fuzz 0))
    (gc)
    (setq g (- (- (distance minp (mapcar '+ minp (mapcar '* v (list k k)))) l)))
    (setq dyy 1e+99)
    (setq i 0)
    (repeat (if (= k 1) 1 (1- k))
      (if (and (< (abs (cadr (setq dxdy (detdxdy (setq i (1+ i)))))) (abs dyy)) (> (abs (cadr dxdy)) 1e-8))
        (setq dx (car dxdy) dy (cadr dxdy) dyy dy)
      )
    )
    (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)
)

Regards, M.R.

HTH.

sups.pat

Edited November 18, 2020 by marko_ribar

[hugha]

Marko,

 

AutoCAD requires .PAT file lines to be strictly 80 characters long or less.

 

You may be able to comply by selectively reducing the output numerical precision.

Note only X and Y coordinate precision can be safely reduced,  other values best kept as exact as you can retain within the line length limit.

 

hope this helps,

Hugh Adamson

www.hatchkit.com.au

 

Edited November 18, 2020 by hugha

[marko_ribar]

Hugh, thanks for your info, I've updated all my codes - now line length is max. 79 characters, but that was not an issue with displaying my *.pat file... I'll reattached it with my mods. upon using my revised last code... Somethings different is the problem, and I don't know what...

Anyway, thanks for your valuable input...

M.R.

sups.pat

[hugha]

Marko,

 

The AutoCAD .PAT file specification requires an additional blank line at the end of the file. 

Your file does not contain that extra line. Add a blank line to the end of the generated file.

 

The last 4 bytes within the file should be cr lf cr lf.   

 

hth,

 

Hugh Adamson

www.hatchkit.com.au

 

 

 

 

 

 

 

 

 

 

 

[marko_ribar]

If I leave it like it is my *.pat file ends with 0D 0A... If I add last blank line it ends with 0D 0A 0D 0A... But in both cases it does not help with my sups.pat file I attached... With *.pat generated with reduced precision geometry it displays, but point is that precision should be as much good as possible - the problem with it is IMHO just by finding data by routine - parameter k may be so big that routine can't finish in reasonable time - also fuzz should be bigger like I hard coded it 1e-6, if it's smaller 1e-10 or more 1e-14 CAD may never find common base point of translated bounding rectangle and ray with starting point at lower left point of bounding rectangle and direction like it is in reference checking line...

Edited November 19, 2020 by marko_ribar

[marko_ribar]

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

Edited November 29, 2020 by marko_ribar