make pat files

June 28

Hi there...

I think I've solved hatching for squares - box 0,0 - 1,1 with density 0.001... This means 1000x1000 precision... All I did is I changed Factor from 100 to 1000 and fuzzines from 0.01 to 0.001, or from 0.001 to 0.0001, or from 0.0001 to 0.00001...

So, you actually don't even have to snap to snaps - you just draw your pattern and when finished you use (c:round) with tolerance : 0.001...

Here are the routines...

;;;CADALYST 10/05 Tip 2065: HatchMaker.lsp	Hatch Maker	(c) 2005 Larry Schiele

;;;* ======   B E G I N   C O D E   N O W    ======   
;;;* HatchMaker.lsp written by Lanny Schiele at TMI Systems Design Corporation
;;;* Lanny.Schiele@tmisystems.com
;;;* Tested on AutoCAD 2002 & 2006. -- does include a 'VL' function -- should work on Acad2000 on up.

(defun C:DrawHatch nil
  (vl-cmdf "_.UNDO" "_BE")
  (setq os (getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (vl-cmdf "_.UCS" "_W")
  (vl-cmdf "_.PLINE" "0,0" "0,1" "1,1" "1,0" "_C")
  (vl-cmdf "_.ZOOM" "_C" "0.5,0.5" 1.1)
  (setvar "OSMODE" os)
  (setvar "SNAPMODE" 1)
  (setvar "SNAPUNIT" (list 0.001 0.001))
  (vl-cmdf "_.UNDO" "_E")
  (alert "Draw pattern within 1x1 box using LINE or POINT entities only...")
  (alert "When you finished drawing pattern in box 0,0 - 1,1; use (c:round) routine to round entities to nearest 0.001 - that should be your tolerance...")
  (princ)
)

(defun C:SaveHatch 
  ( / round    dxf      ListToFile
      user     SelSet   SelSetSize ssNth
      Ent      EntInfo  EntType  pt1 pt2
      Dist     AngTo    AngFrom  XDir YDir
      Gap      DeltaX   DeltaY   AngZone Counter
      Ratio    Factor   HatchName  HatchDescr
      FileLines FileLines FileName
      Scaler   ScaledX  ScaledY  RF x y
      h        _AB      _BC      _AC
      _AD      _DE      _EF      _EH _FH
      DimZin
  )

;;;* BEGIN NESTED FUNCTIONS

  (defun round (num)
    (if (>= (- num (fix num)) 0.5)
      (fix (1+ num))
      (fix num)
    )
  )

  (defun dxf (code EnameOrElist / VarType)
    (setq VarType (type EnameOrElist))
    (if (= VarType (read "ENAME"))
      (cdr (assoc code (entget EnameOrElist)))
      (cdr (assoc code EnameOrElist))
    )
  )

  (defun ListToFile (TextList FileName DoOpenWithNotepad AsAppend / TextItem File RetVal)
    (if (setq File (open FileName (if AsAppend "a" "w")))
      (progn
        (foreach TextItem TextList
          (write-line TextItem File)
        )
        (setq File (close File))
        (if DoOpenWithNotepad
          (startapp "notepad" FileName)
        )
      )
    )
    (FindFile FileName)
  )

;;;* END NESTED FUNCTIONS

  (princ
    (strcat
      "\n."
      "\n    0,1 ----------- 1,1"
      "\n     |               | "
      "\n     |  Lines and    | "
      "\n     |  points must  | "
      "\n     |  be snapped   | "
      "\n     |  to nearest   | "
      "\n     |  0.001        | "
      "\n     |               | "
      "\n    0,0 ----------- 1,0"
      "\n."
      "\nNote:  Lines must be drawn within 0,0 to 1,1 and lie on a 0.001 grid."
     )
  )
  (textscr)
  (getstring "\nHit [ENTER] to continue...")

  (princ "\nSelect 1x1 pattern of lines and/or points for new hatch pattern...")
  (while (not (setq SelSet (ssget (list (cons 0 "LINE,POINT"))))))
  (setq ssNth 0
        SelSetSize (sslength SelSet)
        DimZin (getvar "DIMZIN")
  )
  (setvar "DIMZIN" 11)
  (if (> SelSetSize 0)
    (princ "\nAnalyaing entities...")
  )
  (while (< ssNth SelSetSize)
    (setq Ent (ssname SelSet ssNth)
          EntInfo (entget Ent)
          EntType (dxf 0 EntInfo)
          ssNth (+ ssNth 1)
    )
    (cond
      ( (= EntType "POINT")
        (setq pt1 (dxf 10 EntInfo)
              FileLine (strcat "0," (rtos (car pt1) 2 6) "," (rtos (cadr pt1) 2 6) ",0,1,0,-1")
        )
        (princ (strcat "\n" FileLine))
        (setq FileLines (cons FileLine FileLines))
      )
      ( (= EntType "LINE")
        (setq pt1 (dxf 10 EntInfo)
              pt2 (dxf 11 EntInfo)
              Dist (distance pt1 pt2)
              AngTo (angle pt1 pt2)
              AngFrom (angle pt2 pt1)
              IsValid nil
        )
        (if
          (or (equal (car pt1) (car pt2) 0.00001)
              (equal (cadr pt1) (cadr pt2) 0.00001)
          )
          (setq DeltaX 0
                DeltaY 1
                Gap (- Dist 1)
                IsValid T
          )
          (progn
            (setq Ang (if (< AngTo pi) AngTo AngFrom)
                  AngZone (fix (/ Ang (/ pi 4)))
                  XDir (abs (- (car pt2) (car pt1)))
                  YDir (abs (- (cadr pt2) (cadr pt1)))
                  Factor 1
                  RF 1
            )
            (cond
              ( (= AngZone 0)
                (setq DeltaY (abs (sin Ang))
                      DeltaX (abs (- (abs (/ 1.0 (sin Ang))) (abs (cos Ang))))
                )
              )
              ( (= AngZone 1)
                (setq DeltaY (abs (cos Ang))
                      DeltaX (abs (sin Ang))
                )
              )
              ( (= AngZone 2)
                (setq DeltaY (abs (cos Ang))
                      DeltaX (abs (- (abs (/ 1.0 (cos Ang))) (abs (sin Ang))))
                )
              )
              ( (= AngZone 3)
                (setq DeltaY (abs (sin Ang))
                      DeltaX (abs (cos Ang))
                )
              )
            )
            (if (not (equal XDir YDir 0.0001))
              (progn
                (setq Ratio (if (< XDir YDir) (/ YDir XDir) (/ XDir YDir))
                      RF (* Ratio Factor)
                      Scaler (/ 1 (if (< XDir YDir) XDir YDir))
                )
                (if (not (equal Ratio (round Ratio) 0.0001))
                  (progn
                    (while
                      (and
                        (<= Factor 1000)
                        (not (equal RF (round RF) 0.0001))
                      )
                      (setq Factor (+ Factor 1)
                            RF     (* Ratio Factor)
                      )
                    )
                    (if (and (> Factor 1) (<= Factor 1000))
                      (progn
                        (setq _AB (* XDir Scaler Factor)
                              _BC (* YDir Scaler Factor)
                              _AC (sqrt (+ (* _AB _AB) (* _BC _BC)))
                              _EF 1
                              x   1
                        )
                        (while (< x (- _AB 0.5))
                          (setq y (* x (/ YDir XDir))
                                h (if (< Ang (/ pi 2))
                                    (- (+ 1 (fix y)) y)
                                    (- y (fix y))
                                  )
                          )
                          (if (< h _EF)
                            (setq _AD x
                                  _DE y
                                  _AE (sqrt (+ (* x x) (* y y)))
                                  _EF h
                            )
                          )
                          (setq x (+ x 1))
                        )
                        (if (< _EF 1)
                          (setq _EH (/ (* _BC _EF) _AC)
                                _FH (/ (* _AB _EF) _AC)
                                DeltaX (+ _AE (if (> Ang (/ pi 2)) (- _EH) _EH))
                                DeltaY (+ _FH)
                                Gap (- Dist _AC)
                                IsValid T
                          )
                        )
                      )
                    )
                  )
                )
              )
            )
            (if (= Factor 1)
              (setq Gap (- Dist (abs (* Factor (/ 1 DeltaY))))
                    IsValid T
              )
            )
          )
        )
        (if
          IsValid
          (progn
            (setq FileLine
              (strcat
                (angtos AngTo 0 6)
                ","
                (rtos (car pt1) 2 8)
                ","
                (rtos (cadr pt1) 2 8)
                ","
                (rtos DeltaX 2 8)
                ","
                (rtos DeltaY 2 8)
                ","
                (rtos Dist 2 8)
                ","
                (rtos Gap 2 8)
              )
            )
            (princ (strcat "\n" FileLine))
            (setq FileLines (cons FileLine FileLines))
          )
          (princ (strcat "\n * * *  Line with invalid angle " (angtos AngTo 0 6) (chr 186) " omitted.  * * *"))
        )
      )
      ( (princ (strcat "\n * * *  Invalid entity " EntType " omitted."))
      )
    )
  )
  (setvar "DIMZIN" DimZin)
  (if
    (and
      FileLines
      (setq HatchDescr (getstring T "\nBriefly describe this hatch pattern: "))
      (setq FileName (getfiled "Hatch Pattern File" (strcat (getvar (quote roamablerootprefix)) "support\\") "pat" 1))
    )
    (progn
      (if (= HatchDescr "")
        (setq HatchDescr "Custom hatch pattern")
      )
      (setq HatchName (vl-filename-base FileName)
            FileLines (cons (strcat "*" HatchName "," HatchDescr) (reverse FileLines))
      )
      (princ "\n============================================================")
      (princ (strcat "\nPlease wait while the hatch file is created...\n"))
      (ListToFile FileLines FileName nil nil)
      (while (not (findfile FileName))) ; (vl-cmdf "delay" 1500) ; delay required so file can be created and found (silly, but req.)
      (if (findfile FileName)
        (princ (strcat "\nHatch pattern '" HatchName "' is ready to use!"))
        (progn
          (princ "\nUnable to create hatch pattern file:")
          (princ (strcat "\n  " FileName))
        )
      )
    )
    (princ (if FileLines "\nCancelled." "\nUnable to create hatch pattern from selected entities."))
  )
  (princ)
)
;|
(princ "\n ************************************************************** ")
(princ "\n**                                                            **")
(princ "\n*  HatchMaker.lsp written by Lanny Schiele -- enjoy!           *")
(princ "\n*                                                              *")
(princ "\n*  Type in DRAWHATCH to have the environment created to draw.  *")
(princ "\n*  Type in SAVEHATCH to save the pattern you created.          *")
(princ "\n**                                                            **")
(princ "\n ************************************************************** ")
(princ)
|;

(defun c:round ( / rounddxf roundvalue round e i k l m s )

  (defun rounddxf ( key mod lst / rtn )
    (foreach itm lst
      (if (member (car itm) key)
        (setq rtn (cons (cons (car itm) (roundvalue (cdr itm) mod)) rtn))
        (setq rtn (cons itm rtn))
      )
    )
    (reverse rtn)
  )

  (defun roundvalue ( val mod )
    (if (listp val)
      (mapcar (function (lambda ( x ) (round x mod))) val)
      (round val mod)
    )
  )

  ;; Doug Broad
  (defun round ( value to )
    (setq to (abs to))
    (* to (fix (/ ((if (minusp value) - +) value (* to 0.5)) to)))
  )

  (setq l
   '(
      ("CIRCLE"     10 40)
      ("LINE"       10 11)
      ("LWPOLYLINE" 10)
      ("INSERT"     10)
      ("POINT"      10)
    )
  )            
  (if (null *tol*)
    (setq *tol* 5.0)
  )
  (initget 6)
  (if (setq m (getreal (strcat "\nSpecify rounding tolerance <" (rtos *tol*) ">: ")))
    (setq *tol* m)
    (setq m *tol*)
  )
  (if (setq s (ssget "_:L" '((0 . "CIRCLE,LINE,LWPOLYLINE,INSERT,POINT"))))
    (repeat (setq i (sslength s))
      (if (setq e (entget (ssname s (setq i (1- i)))) k (cdr (assoc (cdr (assoc 0 e)) l)))
        (entmod (rounddxf k m e))
      )
    )
  )
  (princ)
)

HTH.

M.R.

sups-nn.pat

Edited June 30 by marko_ribar

June 28

That's sick @marko_ribar, I'm currently using a 0.005 rounding for mine atm with the same program. I also use the polyline diet lisp to weed out unwanted vertices further.

I couldn't help but notice you have Toolpac. Is the .pat file export quick?

I might try to modify this program to allow the user to pick the lower left-hand corner of the hatch entities to allow easier creation of hatches without the need to same the 1x1 square at 0,0.

June 29

Found this on my travels.

https://qcad.org/rsforum/viewtopic.php?f=30&t=9995#p42607

July 1

I've coded for rectangular boundary like with my lastly posted version... But it creates undesired hatch along main diagonal... Anyway maybe someone with free time try to solve lacks and make it work as desired in all directions for both rows and columns...

So here is my latest version...

(defun c:savehatchfromrecbound ( / *error* trim0trailing trimlineto80chr acet-geom-ss-extents-accurate offsip intrecs makerecs cmde s boundary ch minp maxp w h ex lil fuzz tol rl mm des fn a x y rec ip l g ll f al scf )

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

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

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

  (defun trimlineto80chr ( str / lst )
    (setq lst (vl-string->list str))
    (setq lst (reverse lst))
    (while (> (length lst) 80)
      (setq lst (cdr lst))
    )
    (setq lst (reverse lst))
    (vl-list->string lst)
  )

  (defun acet-geom-ss-extents-accurate ( ss / layers i lck e layer minp maxp minl maxl )
    (if ss
      (progn
        (setq layers (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))))
        (repeat (setq i (sslength ss))
          (setq lck nil)
          (setq e (ssname ss (setq i (1- i))))
          (if (= (vla-get-lock (vla-item layers (setq layer (vla-get-layer (vlax-ename->vla-object e))))) :vlax-true)
            (progn
              (vla-put-lock (vla-item layers layer) :vlax-false)
              (setq lck t)
            )
          )
          (vla-transformby (vlax-ename->vla-object e) (vlax-tmatrix (append (mapcar (function (lambda ( vector origin ) (append (trans vector 1 0 t) (list origin)))) (list (list 1.0 0.0 0.0) (list 0.0 1.0 0.0) (list 0.0 0.0 1.0)) (trans (list 0.0 0.0 0.0) 0 1)) (list (list 0.0 0.0 0.0 1.0)))))
          (vla-getboundingbox (vlax-ename->vla-object e) (quote minp) (quote maxp))
          (vla-transformby (vlax-ename->vla-object e) (vlax-tmatrix (append (mapcar (function (lambda ( vector origin ) (append (trans vector 0 1 t) (list origin)))) (list (list 1.0 0.0 0.0) (list 0.0 1.0 0.0) (list 0.0 0.0 1.0)) (trans (list 0.0 0.0 0.0) 1 0)) (list (list 0.0 0.0 0.0 1.0)))))
          (if lck
            (vla-put-lock (vla-item layers layer) :vlax-true)
          )
          (mapcar (function set) (list (quote minp) (quote maxp)) (mapcar (function safearray-value) (list minp maxp)))
          (setq minl (cons minp minl) maxl (cons maxp maxl))
        )
        (list (apply (function mapcar) (cons (function min) minl)) (apply (function mapcar) (cons (function max) maxl)))
      )
    )
  )

  (defun offsip ( p1 p2 w h / li ip )
    (setq li (entmakex (list (cons 0 "LINE") (cons 10 (trans (mapcar (function +) (list w h) p1) 1 0)) (cons 11 (trans (mapcar (function +) (list w h) p2) 1 0)))))
    (vl-cmdf "_.ucs" "_3p" "_non" (trans p1 1 0) "_non" (trans p2 1 0) "_non" (polar (trans p1 1 0) (+ (* 0.5 pi) (angle (trans p1 1 0) (trans p2 1 0))) 1.0))
    (setq ip (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 10 (entget li))) 0 1)))
    (entdel li)
    (vl-cmdf "_.ucs" "_p")
    ip
  )

  (defun intrecs ( minp maxp p1 p2 tol fuzz / r rec li1 li2 ip iip ipp ip1 ip2 par )
    (setq r (entmakex (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 1) (cons 38 0.0) (cons 10 (trans minp 1 0)) (cons 10 (trans (list (car maxp) (cadr minp)) 1 0)) (cons 10 (trans maxp 1 0)) (cons 10 (trans (list (car minp) (cadr maxp)) 1 0)) (list 210 0.0 0.0 1.0))))
    (setq li1 (entmakex (list (cons 0 "RAY") (cons 100 "AcDbEntity") (cons 100 "AcDbRay") (cons 10 (trans p2 1 0)) (cons 11 (polar (list 0.0 0.0) (angle (trans p2 1 0) (trans p1 1 0)) 1.0)))))
    (setq ip (mapcar (function +) (list 0.0 0.0) (vlax-invoke (vlax-ename->vla-object r) (quote intersectwith) (vlax-ename->vla-object li1) acextendnone)))
    (setq par (vlax-curve-getparamatpoint r (vlax-curve-getclosestpointto r ip)))
    (if (not rl)
      (makerecs minp maxp tol)
    )
    (setq li2 (entmakex (list (cons 0 "RAY") (cons 100 "AcDbEntity") (cons 100 "AcDbRay") (cons 10 (trans p1 1 0)) (cons 11 (polar (list 0.0 0.0) (angle (trans p1 1 0) (trans p2 1 0)) 1.0)))))
    (setq rec (vl-some (function (lambda ( x / ip1 ip2 )
      (setq iip (vlax-invoke (vlax-ename->vla-object x) (quote intersectwith) (vlax-ename->vla-object li2) acextendnone))
      (if iip
        (cond
          ( (= (length iip) 6)
            (setq ip1 (mapcar (function +) (list 0.0 0.0) iip))
            (setq ip2 (mapcar (function +) (list 0.0 0.0) (cdddr iip)))
          )
          ( (= (length iip) 3)
            (setq ip1 (mapcar (function +) (list 0.0 0.0) iip))
          )
        )
      )
      (if (or ip1 ip2)
        (cond
          ( (and ip1 ip2)
            (setq ipp (car (vl-sort (list ip1 ip2) (function (lambda ( a b ) (< (distance (list (/ (+ (car minp) (car maxp)) 2.0) (/ (+ (cadr minp) (cadr maxp)) 2.0)) a) (distance (list (/ (+ (car minp) (car maxp)) 2.0) (/ (+ (cadr minp) (cadr maxp)) 2.0)) b)))))))
          )
          ( ip1 (setq ipp ip1) )
        )
        (setq ipp nil)
      )
      (if (and ipp (equal par (vlax-curve-getparamatpoint x (vlax-curve-getclosestpointto x ipp)) fuzz))
        x
      ))) rl)
    )
    (if (vl-every (function (lambda ( x ) (and x (not (vlax-erased-p x))))) (list r li1 li2))
      (mapcar (function entdel) (list r li1 li2))
    )
    rec
  )

  (defun makerecs ( minp maxp tol / makerec oo o1 o2 o3 o4 o5 o6 o7 o8 l11 l12 l21 l22 l31 l32 l41 l42 )

    (setq mm (if (not mm) minp)) ;;; mm - lexical global variable

    (defun makerec ( o minp maxp / r ) ;;; rl - lexical global variable
      (setq r (entmakex (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 1) (cons 38 0.0) (cons 10 (mapcar (function +) (list 0.0 0.0) o)) (cons 10 (mapcar (function +) (list (- (car maxp) (car minp)) 0.0) o)) (cons 10 (mapcar (function +) (list (- (car maxp) (car minp)) (- (cadr maxp) (cadr minp))) o)) (cons 10 (mapcar (function +) (list 0.0 (- (cadr maxp) (cadr minp))) o)) (list 210 0.0 0.0 1.0))))
      (setq rl (cons r rl))
    )

    (defun oo ( o minp maxp )
      (if (not (equal o mm 1e-6))
        (makerec o minp maxp)
      )
    )

    (if (not rl)
      (repeat tol
        (if (not o1)
          (setq o1 maxp)
        )
        (if (not o2)
          (setq o2 (mapcar (function +) minp (list (- (car maxp) (car minp)) 0.0)))
        )
        (if (not o8)
          (setq o8 (mapcar (function +) minp (list (- (car maxp) (car minp)) (- (cadr minp) (cadr maxp)))))
        )
        (if (not l11)
          (setq l11 (list o1 o2 o8))
        )
        (mapcar (function (lambda ( x ) (oo x minp maxp))) l11)
        (setq l12 (append (list (mapcar (function +) (car l11) (list (- (car maxp) (car minp)) (- (cadr maxp) (cadr minp))))) (mapcar (function (lambda ( x ) (mapcar (function +) (list (- (car maxp) (car minp)) 0.0) x))) l11) (list (mapcar (function +) (last l11) (list (- (car maxp) (car minp)) (- (cadr minp) (cadr maxp)))))))
        (setq l11 l12)
        (if (not o2)
          (setq o2 maxp)
        )
        (if (not o3)
          (setq o3 (mapcar (function +) maxp (list (- (car minp) (car maxp)) 0.0)))
        )
        (if (not o4)
          (setq o4 (mapcar (function +) minp (list (- (car minp) (car maxp)) (- (cadr maxp) (cadr minp)))))
        )
        (if (not l21)
          (setq l21 (list o2 o3 o4))
        )
        (mapcar (function (lambda ( x ) (oo x minp maxp))) l21)
        (setq l22 (append (list (mapcar (function +) (car l21) (list (- (car maxp) (car minp)) (- (cadr maxp) (cadr minp))))) (mapcar (function (lambda ( x ) (mapcar (function +) (list 0.0 (- (cadr maxp) (cadr minp))) x))) l21) (list (mapcar (function +) (last l21) (list (- (car minp) (car maxp)) (- (cadr maxp) (cadr minp)))))))
        (setq l21 l22)
        (if (not o4)
          (setq o4 (mapcar (function +) minp (list (- (car minp) (car maxp)) (- (cadr maxp) (cadr minp)))))
        )
        (if (not o5)
          (setq o5 (mapcar (function +) minp (list (- (car minp) (car maxp)) 0.0)))
        )
        (if (not o6)
          (setq o6 (mapcar (function +) minp (list (- (car minp) (car maxp)) (- (cadr minp) (cadr maxp)))))
        )
        (if (not l31)
          (setq l31 (list o4 o5 o6))
        )
        (mapcar (function (lambda ( x ) (oo x minp maxp))) l31)
        (setq l32 (append (list (mapcar (function +) (car l31) (list (- (car minp) (car maxp)) (- (cadr maxp) (cadr minp))))) (mapcar (function (lambda ( x ) (mapcar (function +) (list (- (car minp) (car maxp)) 0.0) x))) l31) (list (mapcar (function +) (last l31) (list (- (car minp) (car maxp)) (- (cadr minp) (cadr maxp)))))))
        (setq l31 l32)
        (if (not o6)
          (setq o6 (mapcar (function +) minp (list (- (car minp) (car maxp)) (- (cadr minp) (cadr maxp)))))
        )
        (if (not o7)
          (setq o7 (mapcar (function +) minp (list 0.0 (- (cadr minp) (cadr maxp)))))
        )
        (if (not o8)
          (setq o8 (mapcar (function +) minp (list (- (car maxp) (car minp)) (- (cadr minp) (cadr maxp)))))
        )
        (if (not l41)
          (setq l41 (list o6 o7 o8))
        )
        (mapcar (function (lambda ( x ) (oo x minp maxp))) l41)
        (setq l42 (append (list (mapcar (function +) (car l41) (list (- (car minp) (car maxp)) (- (cadr minp) (cadr maxp))))) (mapcar (function (lambda ( x ) (mapcar (function +) (list 0.0 (- (cadr minp) (cadr maxp))) x))) l41) (list (mapcar (function +) (last l41) (list (- (car maxp) (car minp)) (- (cadr minp) (cadr maxp)))))))
        (setq l41 l42)
      )
    )
  )

  (setq cmde (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (alert "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...")
  (while
    (or
      (prompt "\nSelect boundary rectangle and hatching geometry...")
      (not (setq s (ssget (list (cons -4 "<or") (cons 0 "LINE") (cons -4 "<and") (cons 0 "LWPOLYLINE") (cons -4 "<not") (cons -4 "<>") (cons 42 0.0) (cons -4 "not>") (cons -4 "and>") (cons -4 "or>")))))
      (if s
        (not (equal (mapcar (function last) (acet-geom-ss-extents-accurate s)) (list 0.0 0.0) 1e-6))
      )
    )
    (prompt "\nEmpty sel set or selected geometry not planar with WCS...")
  )
  (setq boundary (ssname (ssget "_C" (setq oo (car (acet-geom-ss-extents-accurate s))) oo (list (cons 0 "LWPOLYLINE") (cons 90 4) (cons -4 "&=") (cons 70 1) (cons -4 "<not") (cons -4 "<>") (cons 42 0.0) (cons -4 "not>"))) 0))
  (initget "Yes No")
  (setq ch (getkword "\nDo you want to implement boundary into hatch [Yes/No] <No> : "))
  (mapcar (function set) (list (quote minp) (quote maxp)) (acet-geom-ss-extents-accurate (ssadd boundary)))
  (setq minp (mapcar (function +) (list 0.0 0.0) minp))
  (setq maxp (mapcar (function +) (list 0.0 0.0) maxp))
  (setq w (- (car maxp) (car minp)) h (- (cadr maxp) (cadr minp)))
  (if (= ch "Yes")
    (progn
      (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) minp) (mapcar (function +) (list w 0.0) minp)) lil))
      (setq lil (cons (list (mapcar (function +) (list w 0.0) minp) (mapcar (function +) (list 0.0 0.0) maxp)) lil))
      (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) maxp) (mapcar (function +) (list (- w) 0.0) maxp)) lil))
      (setq lil (cons (list (mapcar (function +) (list (- w) 0.0) maxp) (mapcar (function +) (list 0.0 0.0) minp)) lil))
    )
  )
  (ssdel boundary s)
  (foreach e (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s)))
    (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 10 (setq ex (entget e)))) 0 1)) (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 11 ex)) 0 1))) lil))
  )
  (setq lil (reverse lil))
  (initget 6)
  (setq fuzz (getreal "\nSpecify fuzz factor for determining gap - <0.005> : "))
  (if (null fuzz)
    (setq fuzz 0.005)
  )
  (initget 6)
  (setq tol (getint "\nSpecify tolerance factor for determining gap - <1000> : "))
  (if (null tol)
    (setq tol 1000)
  )
  (initget 1)
  (setq des (getstring "\nSpecify description : "))
  (while (or (not (snvalid des)) (> (strlen des) 8))
    (prompt "\nSpecified string not valid, or number of characters greater than 8...")
    (initget 1)
    (setq des (getstring "\nSpecify description : "))
  )
  (setq fn (getfiled "Specify PATTERN file..." (strcat (getvar (quote roamablerootprefix)) "support\\") "pat" 1))
  (while (or (not (snvalid (vl-filename-base fn))) (> (strlen (vl-filename-base fn)) 8))
    (prompt "\nSpecified filename not valid, or number of characters greater than 8...")
    (setq fn (getfiled "Specify PATTERN file..." (strcat (getvar (quote roamablerootprefix)) "support\\") "pat" 1))
  )
  (foreach li lil
    (setq a (angle (car li) (cadr li)))
    (setq l (distance (car li) (cadr li)))
    (setq x (caar li) y (cadar li))
    (setq ip (offsip (car li) (cadr li) w h))
    (setq rec (intrecs minp maxp (car li) (cadr li) tol fuzz))
    (if rec
      (progn
        (setq g (- (distance minp (cdr (assoc 10 (entget rec)))) l))
        (setq ll (cons (list (cvunit a "radian" "degree") x y (car ip) (cadr ip) l (- g)) ll)) ;;; angle, x-origin, y-origin, delta-x, delta-y, length, dash gap ;;;
        (setq al (cons (cvunit a "radian" "degree") al))
      )
    )
  )
  (if rl
    (mapcar (function entdel) rl)
  )
  (setq ll (reverse ll))
  (setq al (reverse al))
  (initget 6)
  (setq scf (getreal "\nSpecify scale factor for multiplication hatch data <1.0> : "))
  (if (null scf)
    (setq scf 1.0)
  )
  (setq ll (mapcar (function (lambda ( x ) (mapcar (function (lambda ( y ) (* y scf))) x))) ll))
  (setq f (open fn "w"))
  (write-line (strcat "*" (vl-filename-base fn) ", " des) f)
  (setq k -1)
  (foreach li ll
    (setq k (1+ k))
    (if (zerop (last li))
      (write-line (trimlineto80chr (strcat (trim0trailing (rtos (nth k al) 2 8)) "," (trim0trailing (rtos (cadr li) 2 8)) "," (trim0trailing (rtos (caddr li) 2 8)) "," (trim0trailing (rtos (nth 3 li) 2 8)) "," (trim0trailing (rtos (nth 4 li) 2 8)))) f)
      (write-line (trimlineto80chr (strcat (trim0trailing (rtos (nth k al) 2 8)) "," (trim0trailing (rtos (cadr li) 2 8)) "," (trim0trailing (rtos (caddr li) 2 8)) "," (trim0trailing (rtos (nth 3 li) 2 8)) "," (trim0trailing (rtos (nth 4 li) 2 8)) "," (trim0trailing (rtos (nth 5 li) 2 8)) "," (trim0trailing (rtos (nth 6 li) 2 8)))) f)
    )
  )
  (close f)
  (*error* nil)
)

HTH.

Regards, M.R.

Edited July 2 by marko_ribar

July 2

Here is my latest attempt on the issue with rectangular hatchings... But you must know that it goes slow like my previous posted code... Still not sure what will it throw out... It needs more testings...

(defun c:savehatchfromrecbound ( / *error* trim0trailing trimlineto80chr acet-geom-ss-extents-accurate offsip intrecs makerecs cmde s boundary ch minp maxp w h ex lil fuzz fuzzz tol rl rr mm des fn a x y rec1 rec2 recs r2x ip l g ll f al scf )

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

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

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

  (defun trimlineto80chr ( str / lst )
    (setq lst (vl-string->list str))
    (setq lst (reverse lst))
    (while (> (length lst) 80)
      (setq lst (cdr lst))
    )
    (setq lst (reverse lst))
    (vl-list->string lst)
  )

  (defun acet-geom-ss-extents-accurate ( ss / layers i lck e layer minp maxp minl maxl )
    (if ss
      (progn
        (setq layers (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))))
        (repeat (setq i (sslength ss))
          (setq lck nil)
          (setq e (ssname ss (setq i (1- i))))
          (if (= (vla-get-lock (vla-item layers (setq layer (vla-get-layer (vlax-ename->vla-object e))))) :vlax-true)
            (progn
              (vla-put-lock (vla-item layers layer) :vlax-false)
              (setq lck t)
            )
          )
          (vla-transformby (vlax-ename->vla-object e) (vlax-tmatrix (append (mapcar (function (lambda ( vector origin ) (append (trans vector 1 0 t) (list origin)))) (list (list 1.0 0.0 0.0) (list 0.0 1.0 0.0) (list 0.0 0.0 1.0)) (trans (list 0.0 0.0 0.0) 0 1)) (list (list 0.0 0.0 0.0 1.0)))))
          (vla-getboundingbox (vlax-ename->vla-object e) (quote minp) (quote maxp))
          (vla-transformby (vlax-ename->vla-object e) (vlax-tmatrix (append (mapcar (function (lambda ( vector origin ) (append (trans vector 0 1 t) (list origin)))) (list (list 1.0 0.0 0.0) (list 0.0 1.0 0.0) (list 0.0 0.0 1.0)) (trans (list 0.0 0.0 0.0) 1 0)) (list (list 0.0 0.0 0.0 1.0)))))
          (if lck
            (vla-put-lock (vla-item layers layer) :vlax-true)
          )
          (mapcar (function set) (list (quote minp) (quote maxp)) (mapcar (function safearray-value) (list minp maxp)))
          (setq minl (cons minp minl) maxl (cons maxp maxl))
        )
        (list (apply (function mapcar) (cons (function min) minl)) (apply (function mapcar) (cons (function max) maxl)))
      )
    )
  )

  (defun offsip ( p1 p2 w h / li ip )
    (setq li (entmakex (list (cons 0 "LINE") (cons 10 (trans (mapcar (function +) (list w h) p1) 1 0)) (cons 11 (trans (mapcar (function +) (list w h) p2) 1 0)))))
    (vl-cmdf "_.ucs" "_3p" "_non" (trans p1 1 0) "_non" (trans p2 1 0) "_non" (polar (trans p1 1 0) (+ (* 0.5 pi) (angle (trans p1 1 0) (trans p2 1 0))) 1.0))
    (setq ip (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 10 (entget li))) 0 1)))
    (entdel li)
    (vl-cmdf "_.ucs" "_p")
    ip
  )

  (defun intrecs ( minp maxp p1 p2 tol fuzz fuzzz / r rec li1 li2 ip iip ipp ip1 ip2 par )
    (setq r (entmakex (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 1) (cons 38 0.0) (cons 10 (trans minp 1 0)) (cons 10 (trans (list (car maxp) (cadr minp)) 1 0)) (cons 10 (trans maxp 1 0)) (cons 10 (trans (list (car minp) (cadr maxp)) 1 0)) (list 210 0.0 0.0 1.0))))
    (setq li1 (entmakex (list (cons 0 "RAY") (cons 100 "AcDbEntity") (cons 100 "AcDbRay") (cons 10 (trans p2 1 0)) (cons 11 (polar (list 0.0 0.0) (angle (trans p2 1 0) (trans p1 1 0)) 1.0)))))
    (setq ip (mapcar (function +) (list 0.0 0.0) (vlax-invoke (vlax-ename->vla-object r) (quote intersectwith) (vlax-ename->vla-object li1) acextendnone)))
    (setq par (vlax-curve-getparamatpoint r (vlax-curve-getclosestpointto r ip)))
    (if (not rl)
      (progn
        (makerecs minp maxp tol)
        (setq rr (reverse rl)) ;;; rr - lexical global variable
      )
    )
    (setq li2 (entmakex (list (cons 0 "RAY") (cons 100 "AcDbEntity") (cons 100 "AcDbRay") (cons 10 (trans p1 1 0)) (cons 11 (polar (list 0.0 0.0) (angle (trans p1 1 0) (trans p2 1 0)) 1.0)))))
    (setq rec1 (vl-some (function (lambda ( x / ip1 ip2 )
      (setq iip (vlax-invoke (vlax-ename->vla-object x) (quote intersectwith) (vlax-ename->vla-object li2) acextendnone))
      (if iip
        (cond
          ( (= (length iip) 6)
            (setq ip1 (mapcar (function +) (list 0.0 0.0) iip))
            (setq ip2 (mapcar (function +) (list 0.0 0.0) (cdddr iip)))
          )
          ( (= (length iip) 3)
            (setq ip1 (mapcar (function +) (list 0.0 0.0) iip))
          )
        )
      )
      (if (or ip1 ip2)
        (cond
          ( (and ip1 ip2)
            (setq ipp (car (vl-sort (list ip1 ip2) (function (lambda ( a b ) (< (distance (list (/ (+ (car minp) (car maxp)) 2.0) (/ (+ (cadr minp) (cadr maxp)) 2.0)) a) (distance (list (/ (+ (car minp) (car maxp)) 2.0) (/ (+ (cadr minp) (cadr maxp)) 2.0)) b)))))))
          )
          ( ip1 (setq ipp ip1) )
        )
        (setq ipp nil)
      )
      (if (and ipp (equal par (vlax-curve-getparamatpoint x (vlax-curve-getclosestpointto x ipp)) fuzz))
        x
      ))) rl)
    )
    (setq rec2 (vl-some (function (lambda ( x / ip1 ip2 )
      (setq iip (vlax-invoke (vlax-ename->vla-object x) (quote intersectwith) (vlax-ename->vla-object li2) acextendnone))
      (if iip
        (cond
          ( (= (length iip) 6)
            (setq ip1 (mapcar (function +) (list 0.0 0.0) iip))
            (setq ip2 (mapcar (function +) (list 0.0 0.0) (cdddr iip)))
          )
          ( (= (length iip) 3)
            (setq ip1 (mapcar (function +) (list 0.0 0.0) iip))
          )
        )
      )
      (if (or ip1 ip2)
        (cond
          ( (and ip1 ip2)
            (setq ipp (car (vl-sort (list ip1 ip2) (function (lambda ( a b ) (< (distance (list (/ (+ (car minp) (car maxp)) 2.0) (/ (+ (cadr minp) (cadr maxp)) 2.0)) a) (distance (list (/ (+ (car minp) (car maxp)) 2.0) (/ (+ (cadr minp) (cadr maxp)) 2.0)) b)))))))
          )
          ( ip1 (setq ipp ip1) )
        )
        (setq ipp nil)
      )
      (if (and ipp (equal par (vlax-curve-getparamatpoint x (vlax-curve-getclosestpointto x ipp)) fuzzz))
        x
      ))) rr)
    )
    (if (vl-every (function (lambda ( x ) (and x (not (vlax-erased-p x))))) (list r li1 li2))
      (mapcar (function entdel) (list r li1 li2))
    )
    (list rec1 rec2)
  )

  (defun makerecs ( minp maxp tol / makerec oo o1 o2 o3 o4 o5 o6 o7 o8 l11 l12 l21 l22 l31 l32 l41 l42 ll )

    (setq mm (if (not mm) minp)) ;;; mm - lexical global variable

    (defun makerec ( o minp maxp / r ) ;;; rl - lexical global variable
      (setq r (entmakex (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 1) (cons 38 0.0) (cons 10 (mapcar (function +) (list 0.0 0.0) o)) (cons 10 (mapcar (function +) (list (- (car maxp) (car minp)) 0.0) o)) (cons 10 (mapcar (function +) (list (- (car maxp) (car minp)) (- (cadr maxp) (cadr minp))) o)) (cons 10 (mapcar (function +) (list 0.0 (- (cadr maxp) (cadr minp))) o)) (list 210 0.0 0.0 1.0))))
      (setq rl (cons r rl))
    )

    (defun oo ( o minp maxp )
      (if (not (equal o mm 1e-6))
        (makerec o minp maxp)
      )
    )

    (if (not rl)
      (progn
        (repeat tol
          (gc)
          (if (not o1)
            (setq o1 maxp)
          )
          (if (not o2)
            (setq o2 (mapcar (function +) minp (list (- (car maxp) (car minp)) 0.0)))
          )
          (if (not o8)
            (setq o8 (mapcar (function +) minp (list (- (car maxp) (car minp)) (- (cadr minp) (cadr maxp)))))
          )
          (if (not l11)
            (setq l11 (list o1 o2 o8))
          )
          (foreach o (vl-remove (car l11) (vl-remove (last l11) l11))
            (setq ll (cons o ll))
          )
          (foreach o (list (car l11) (last l11))
            (if (not (equal o (car ll) 1e-6))
              (setq ll (cons o ll))
            )
          )
          (setq l12 (append (list (mapcar (function +) (car l11) (list (- (car maxp) (car minp)) (- (cadr maxp) (cadr minp))))) (mapcar (function (lambda ( x ) (mapcar (function +) (list (- (car maxp) (car minp)) 0.0) x))) l11) (list (mapcar (function +) (last l11) (list (- (car maxp) (car minp)) (- (cadr minp) (cadr maxp)))))))
          (setq l11 l12)
          (if (not o2)
            (setq o2 maxp)
          )
          (if (not o3)
            (setq o3 (mapcar (function +) maxp (list (- (car minp) (car maxp)) 0.0)))
          )
          (if (not o4)
            (setq o4 (mapcar (function +) minp (list (- (car minp) (car maxp)) (- (cadr maxp) (cadr minp)))))
          )
          (if (not l21)
            (setq l21 (list o2 o3 o4))
          )
          (foreach o (vl-remove (car l21) (vl-remove (last l21) l21))
            (setq ll (cons o ll))
          )
          (foreach o (list (car l21) (last l21))
            (if (not (equal o (car ll) 1e-6))
              (setq ll (cons o ll))
            )
          )
          (setq l22 (append (list (mapcar (function +) (car l21) (list (- (car maxp) (car minp)) (- (cadr maxp) (cadr minp))))) (mapcar (function (lambda ( x ) (mapcar (function +) (list 0.0 (- (cadr maxp) (cadr minp))) x))) l21) (list (mapcar (function +) (last l21) (list (- (car minp) (car maxp)) (- (cadr maxp) (cadr minp)))))))
          (setq l21 l22)
          (if (not o4)
            (setq o4 (mapcar (function +) minp (list (- (car minp) (car maxp)) (- (cadr maxp) (cadr minp)))))
          )
          (if (not o5)
            (setq o5 (mapcar (function +) minp (list (- (car minp) (car maxp)) 0.0)))
          )
          (if (not o6)
            (setq o6 (mapcar (function +) minp (list (- (car minp) (car maxp)) (- (cadr minp) (cadr maxp)))))
          )
          (if (not l31)
            (setq l31 (list o4 o5 o6))
          )
          (foreach o (vl-remove (car l31) (vl-remove (last l31) l31))
            (setq ll (cons o ll))
          )
          (foreach o (list (car l31) (last l31))
            (if (not (equal o (car ll) 1e-6))
              (setq ll (cons o ll))
            )
          )
          (setq l32 (append (list (mapcar (function +) (car l31) (list (- (car minp) (car maxp)) (- (cadr maxp) (cadr minp))))) (mapcar (function (lambda ( x ) (mapcar (function +) (list (- (car minp) (car maxp)) 0.0) x))) l31) (list (mapcar (function +) (last l31) (list (- (car minp) (car maxp)) (- (cadr minp) (cadr maxp)))))))
          (setq l31 l32)
          (if (not o6)
            (setq o6 (mapcar (function +) minp (list (- (car minp) (car maxp)) (- (cadr minp) (cadr maxp)))))
          )
          (if (not o7)
            (setq o7 (mapcar (function +) minp (list 0.0 (- (cadr minp) (cadr maxp)))))
          )
          (if (not o8)
            (setq o8 (mapcar (function +) minp (list (- (car maxp) (car minp)) (- (cadr minp) (cadr maxp)))))
          )
          (if (not l41)
            (setq l41 (list o6 o7 o8))
          )
          (foreach o (vl-remove (car l41) (vl-remove (last l41) l41))
            (setq ll (cons o ll))
          )
          (foreach o (list (car l41) (last l41))
            (if (not (equal o (car ll) 1e-6))
              (setq ll (cons o ll))
            )
          )
          (setq l42 (append (list (mapcar (function +) (car l41) (list (- (car minp) (car maxp)) (- (cadr minp) (cadr maxp))))) (mapcar (function (lambda ( x ) (mapcar (function +) (list 0.0 (- (cadr minp) (cadr maxp))) x))) l41) (list (mapcar (function +) (last l41) (list (- (car maxp) (car minp)) (- (cadr minp) (cadr maxp)))))))
          (setq l41 l42)
        )
        (mapcar (function (lambda ( x ) (oo x minp maxp))) (vl-remove nil (reverse ll)))
      )
    )
  )

  (setq cmde (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (alert "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...")
  (while
    (or
      (prompt "\nSelect boundary rectangle and hatching geometry...")
      (not (setq s (ssget (list (cons -4 "<or") (cons 0 "LINE") (cons -4 "<and") (cons 0 "LWPOLYLINE") (cons -4 "<not") (cons -4 "<>") (cons 42 0.0) (cons -4 "not>") (cons -4 "and>") (cons -4 "or>")))))
      (if s
        (not (equal (mapcar (function last) (acet-geom-ss-extents-accurate s)) (list 0.0 0.0) 1e-6))
      )
    )
    (prompt "\nEmpty sel set or selected geometry not planar with WCS...")
  )
  (setq boundary (ssname (ssget "_C" (setq oo (car (acet-geom-ss-extents-accurate s))) oo (list (cons 0 "LWPOLYLINE") (cons 90 4) (cons -4 "&=") (cons 70 1) (cons -4 "<not") (cons -4 "<>") (cons 42 0.0) (cons -4 "not>"))) 0))
  (initget "Yes No")
  (setq ch (getkword "\nDo you want to implement boundary into hatch [Yes/No] <No> : "))
  (mapcar (function set) (list (quote minp) (quote maxp)) (acet-geom-ss-extents-accurate (ssadd boundary)))
  (setq minp (mapcar (function +) (list 0.0 0.0) minp))
  (setq maxp (mapcar (function +) (list 0.0 0.0) maxp))
  (setq w (- (car maxp) (car minp)) h (- (cadr maxp) (cadr minp)))
  (if (= ch "Yes")
    (progn
      (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) minp) (mapcar (function +) (list w 0.0) minp)) lil))
      (setq lil (cons (list (mapcar (function +) (list w 0.0) minp) (mapcar (function +) (list 0.0 0.0) maxp)) lil))
      (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) maxp) (mapcar (function +) (list (- w) 0.0) maxp)) lil))
      (setq lil (cons (list (mapcar (function +) (list (- w) 0.0) maxp) (mapcar (function +) (list 0.0 0.0) minp)) lil))
    )
  )
  (ssdel boundary s)
  (foreach e (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s)))
    (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 10 (setq ex (entget e)))) 0 1)) (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 11 ex)) 0 1))) lil))
  )
  (setq lil (reverse lil))
  (initget 6)
  (setq fuzz (getreal "\nSpecify fuzz factor for determining gap - <0.005> : "))
  (if (null fuzz)
    (setq fuzz 0.005)
  )
  (setq fuzzz (* 5.0 fuzz))
  (initget 6)
  (setq tol (getint "\nSpecify tolerance factor of around rings for determining gap - <1000> : "))
  (if (null tol)
    (setq tol 1000)
  )
  (initget 1)
  (setq des (getstring "\nSpecify description : "))
  (while (or (not (snvalid des)) (> (strlen des) 8))
    (prompt "\nSpecified string not valid, or number of characters greater than 8...")
    (initget 1)
    (setq des (getstring "\nSpecify description : "))
  )
  (setq fn (getfiled "Specify PATTERN file..." (strcat (getvar (quote roamablerootprefix)) "support\\") "pat" 1))
  (while (or (not (snvalid (vl-filename-base fn))) (> (strlen (vl-filename-base fn)) 8))
    (prompt "\nSpecified filename not valid, or number of characters greater than 8...")
    (setq fn (getfiled "Specify PATTERN file..." (strcat (getvar (quote roamablerootprefix)) "support\\") "pat" 1))
  )
  (foreach li lil
    (setq a (angle (car li) (cadr li)))
    (setq l (distance (car li) (cadr li)))
    (setq x (caar li) y (cadar li))
    (setq recs (intrecs minp maxp (car li) (cadr li) tol fuzz fuzzz))
    (if (and (setq rec1 (car recs)) (setq rec2 (cadr recs)))
      (progn
        (setq ip (offsip (car li) (cadr li) (- (car (cdr (assoc 10 (setq r2x (entget rec2))))) (car minp)) (- (cadr (cdr (assoc 10 r2x))) (cadr minp))))
        (setq g (- (distance minp (cdr (assoc 10 (entget rec1)))) l))
        (setq ll (cons (list (cvunit a "radian" "degree") x y (car ip) (cadr ip) l (- g)) ll)) ;;; angle, x-origin, y-origin, delta-x, delta-y, length, dash gap ;;;
        (setq al (cons (cvunit a "radian" "degree") al))
      )
    )
  )
  (if rl
    (mapcar (function entdel) rl)
  )
  (setq ll (reverse ll))
  (setq al (reverse al))
  (initget 6)
  (setq scf (getreal "\nSpecify scale factor for multiplication hatch data <1.0> : "))
  (if (null scf)
    (setq scf 1.0)
  )
  (setq ll (mapcar (function (lambda ( x ) (mapcar (function (lambda ( y ) (* y scf))) x))) ll))
  (setq f (open fn "w"))
  (write-line (strcat "*" (vl-filename-base fn) ", " des) f)
  (setq k -1)
  (foreach li ll
    (setq k (1+ k))
    (if (zerop (last li))
      (write-line (trimlineto80chr (strcat (trim0trailing (rtos (nth k al) 2 6)) "," (trim0trailing (rtos (cadr li) 2 6)) "," (trim0trailing (rtos (caddr li) 2 6)) "," (trim0trailing (rtos (nth 3 li) 2 6)) "," (trim0trailing (rtos (nth 4 li) 2 6)))) f)
      (write-line (trimlineto80chr (strcat (trim0trailing (rtos (nth k al) 2 6)) "," (trim0trailing (rtos (cadr li) 2 6)) "," (trim0trailing (rtos (caddr li) 2 6)) "," (trim0trailing (rtos (nth 3 li) 2 6)) "," (trim0trailing (rtos (nth 4 li) 2 6)) "," (trim0trailing (rtos (nth 5 li) 2 6)) "," (trim0trailing (rtos (nth 6 li) 2 6)))) f)
    )
  )
  (close f)
  (*error* nil)
)

HTH.

Regards, M.R.

Edited July 4 by marko_ribar

July 3

Can someone review my last code and try to make it more reliable and faster... I am having problems in testing it as my PC is very old (8 GB - RAM)... Intel i5 CPU - Laptop... I'll attach *.DWG for testings... It's superman logo in rectangular boundary...

Thanks...

M.R.

sups-rec.dwg

July 4

9 hours ago, marko_ribar said:

Can someone review my last code and try to make it more reliable and faster... I am having problems in testing it as my PC is very old (8 GB - RAM)... Intel i5 CPU - Laptop... I'll attach *.DWG for testings... It's superman logo in rectangular boundary...

Thanks...

M.R.

sups-rec.dwg 48.32 kB · 1 download

Threadripper 1950X 16-Core Processor, 128GB RAM.

It's still going after 7 mins. Going to stop it now.

July 4

My Laptop is not so slow, but we need actully improvement of the code... I wrote what I thought is this rectangular hatchings is all about... Still you may fasten it if you lower tolerance from 1500 to 1000 for ex. ... But then you'll loose on final resulting *.pat file desired outlook... Unfortunately I don't know to write differently, so I guess you'll have to wait for PC to finish... I suppose you do have BricsCAD which is faster with LISP than AutoCAD...

July 4

Not good at all... This is what I got after around 6000 seconds... Reference for "sups-rec.pat" file was already posted "sups-rec.dwg"... So, perhaps someone with some new method should chime in - if that method exist!!!

Regards, so long from me...

M.R.

sups-rec.pat

July 4

1 hour ago, marko_ribar said:

Not good at all... This is what I got after around 6000 seconds... Reference for "sups-rec.pat" file was already posted "sups-rec.dwg"... So, perhaps someone with some new method should chime in - if that method exist!!!

Regards, so long from me...

M.R.

sups-rec.pat 14.41 kB · 0 downloads

Thanks for taking a look into this. Greatly appreciated! I don't have the knowledge to help. Otherwise I would.

Hopefully, someone can help you. All the best.

July 4

Now I cheated... All in order to get rectangular hatch... And I did it, but hatch definition is now very big - something between 7 and 8 MB (481 times more lines than original with 247 lines)... It still took me around an hour or 1.5 hours, but it went OK... You can visibly look how it works with UCS changing in a milliseconds...

Here is the code :

(defun c:savehatchfromrecbound ( / *error* trim0trailing trimlineto80chr acet-geom-ss-extents-accurate offsip intrecs makerecs cmde s boundary ch minp maxp w h ex lil tol rr des fn a x y ip l g ll f al scf )

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

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

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

  (defun trimlineto80chr ( str / lst )
    (setq lst (vl-string->list str))
    (setq lst (reverse lst))
    (while (> (length lst) 80)
      (setq lst (cdr lst))
    )
    (setq lst (reverse lst))
    (vl-list->string lst)
  )

  (defun acet-geom-ss-extents-accurate ( ss / layers i lck e layer minp maxp minl maxl )
    (if ss
      (progn
        (setq layers (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))))
        (repeat (setq i (sslength ss))
          (setq lck nil)
          (setq e (ssname ss (setq i (1- i))))
          (if (= (vla-get-lock (vla-item layers (setq layer (vla-get-layer (vlax-ename->vla-object e))))) :vlax-true)
            (progn
              (vla-put-lock (vla-item layers layer) :vlax-false)
              (setq lck t)
            )
          )
          (vla-transformby (vlax-ename->vla-object e) (vlax-tmatrix (append (mapcar (function (lambda ( vector origin ) (append (trans vector 1 0 t) (list origin)))) (list (list 1.0 0.0 0.0) (list 0.0 1.0 0.0) (list 0.0 0.0 1.0)) (trans (list 0.0 0.0 0.0) 0 1)) (list (list 0.0 0.0 0.0 1.0)))))
          (vla-getboundingbox (vlax-ename->vla-object e) (quote minp) (quote maxp))
          (vla-transformby (vlax-ename->vla-object e) (vlax-tmatrix (append (mapcar (function (lambda ( vector origin ) (append (trans vector 0 1 t) (list origin)))) (list (list 1.0 0.0 0.0) (list 0.0 1.0 0.0) (list 0.0 0.0 1.0)) (trans (list 0.0 0.0 0.0) 1 0)) (list (list 0.0 0.0 0.0 1.0)))))
          (if lck
            (vla-put-lock (vla-item layers layer) :vlax-true)
          )
          (mapcar (function set) (list (quote minp) (quote maxp)) (mapcar (function safearray-value) (list minp maxp)))
          (setq minl (cons minp minl) maxl (cons maxp maxl))
        )
        (list (apply (function mapcar) (cons (function min) minl)) (apply (function mapcar) (cons (function max) maxl)))
      )
    )
  )

  (defun offsip ( p1 p2 o / w h li ip )
    (setq w (- (car o) (car minp)) h (- (cadr o) (cadr minp)))
    (setq li (entmakex (list (cons 0 "LINE") (cons 10 (trans (mapcar (function +) (list w h) p1) 1 0)) (cons 11 (trans (mapcar (function +) (list w h) p2) 1 0)))))
    (vl-cmdf "_.ucs" "_3p" "_non" (trans p1 1 0) "_non" (trans p2 1 0) "_non" (polar (trans p1 1 0) (+ (* 0.5 pi) (angle (trans p1 1 0) (trans p2 1 0))) 1.0))
    (setq ip (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 10 (entget li))) 0 1)))
    (entdel li)
    (vl-cmdf "_.ucs" "_p")
    ip
  )

  (defun makerecs ( minp maxp tol / o1 o2 o3 o4 o5 o6 o7 o8 l11 l12 l21 l22 l31 l32 l41 l42 )
    (setq rr (cons minp rr))
    (repeat tol
      (gc)
      (if (not o1)
        (setq o1 maxp)
      )
      (if (not o2)
        (setq o2 (mapcar (function +) minp (list (- (car maxp) (car minp)) 0.0)))
      )
      (if (not o8)
        (setq o8 (mapcar (function +) minp (list (- (car maxp) (car minp)) (- (cadr minp) (cadr maxp)))))
      )
      (if (not l11)
        (setq l11 (list o1 o2 o8))
      )
      (foreach o (vl-remove (car l11) (vl-remove (last l11) l11))
        (setq rr (cons o rr))
      )
      (foreach o (list (car l11) (last l11))
        (if (not (equal o (car rr) 1e-6))
          (setq rr (cons o rr))
        )
      )
      (setq l12 (append (list (mapcar (function +) (car l11) (list (- (car maxp) (car minp)) (- (cadr maxp) (cadr minp))))) (mapcar (function (lambda ( x ) (mapcar (function +) (list (- (car maxp) (car minp)) 0.0) x))) l11) (list (mapcar (function +) (last l11) (list (- (car maxp) (car minp)) (- (cadr minp) (cadr maxp)))))))
      (setq l11 l12)
      (if (not o2)
        (setq o2 maxp)
      )
      (if (not o3)
        (setq o3 (mapcar (function +) maxp (list (- (car minp) (car maxp)) 0.0)))
      )
      (if (not o4)
        (setq o4 (mapcar (function +) minp (list (- (car minp) (car maxp)) (- (cadr maxp) (cadr minp)))))
      )
      (if (not l21)
        (setq l21 (list o2 o3 o4))
      )
      (foreach o (vl-remove (car l21) (vl-remove (last l21) l21))
        (setq rr (cons o rr))
      )
      (foreach o (list (car l21) (last l21))
        (if (not (equal o (car rr) 1e-6))
          (setq rr (cons o rr))
        )
      )
      (setq l22 (append (list (mapcar (function +) (car l21) (list (- (car maxp) (car minp)) (- (cadr maxp) (cadr minp))))) (mapcar (function (lambda ( x ) (mapcar (function +) (list 0.0 (- (cadr maxp) (cadr minp))) x))) l21) (list (mapcar (function +) (last l21) (list (- (car minp) (car maxp)) (- (cadr maxp) (cadr minp)))))))
      (setq l21 l22)
      (if (not o4)
        (setq o4 (mapcar (function +) minp (list (- (car minp) (car maxp)) (- (cadr maxp) (cadr minp)))))
      )
      (if (not o5)
        (setq o5 (mapcar (function +) minp (list (- (car minp) (car maxp)) 0.0)))
      )
      (if (not o6)
        (setq o6 (mapcar (function +) minp (list (- (car minp) (car maxp)) (- (cadr minp) (cadr maxp)))))
      )
      (if (not l31)
        (setq l31 (list o4 o5 o6))
      )
      (foreach o (vl-remove (car l31) (vl-remove (last l31) l31))
        (setq rr (cons o rr))
      )
      (foreach o (list (car l31) (last l31))
        (if (not (equal o (car rr) 1e-6))
          (setq rr (cons o rr))
        )
      )
      (setq l32 (append (list (mapcar (function +) (car l31) (list (- (car minp) (car maxp)) (- (cadr maxp) (cadr minp))))) (mapcar (function (lambda ( x ) (mapcar (function +) (list (- (car minp) (car maxp)) 0.0) x))) l31) (list (mapcar (function +) (last l31) (list (- (car minp) (car maxp)) (- (cadr minp) (cadr maxp)))))))
      (setq l31 l32)
      (if (not o6)
        (setq o6 (mapcar (function +) minp (list (- (car minp) (car maxp)) (- (cadr minp) (cadr maxp)))))
      )
      (if (not o7)
        (setq o7 (mapcar (function +) minp (list 0.0 (- (cadr minp) (cadr maxp)))))
      )
      (if (not o8)
        (setq o8 (mapcar (function +) minp (list (- (car maxp) (car minp)) (- (cadr minp) (cadr maxp)))))
      )
      (if (not l41)
        (setq l41 (list o6 o7 o8))
      )
      (foreach o (vl-remove (car l41) (vl-remove (last l41) l41))
        (setq rr (cons o rr))
      )
      (foreach o (list (car l41) (last l41))
        (if (not (equal o (car rr) 1e-6))
          (setq rr (cons o rr))
        )
      )
      (setq l42 (append (list (mapcar (function +) (car l41) (list (- (car minp) (car maxp)) (- (cadr minp) (cadr maxp))))) (mapcar (function (lambda ( x ) (mapcar (function +) (list 0.0 (- (cadr minp) (cadr maxp))) x))) l41) (list (mapcar (function +) (last l41) (list (- (car maxp) (car minp)) (- (cadr minp) (cadr maxp)))))))
      (setq l41 l42)
    )
    (vl-remove nil rr)
  )

  (setq cmde (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (alert "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...")
  (while
    (or
      (prompt "\nSelect boundary rectangle and hatching geometry...")
      (not (setq s (ssget (list (cons -4 "<or") (cons 0 "LINE") (cons -4 "<and") (cons 0 "LWPOLYLINE") (cons -4 "<not") (cons -4 "<>") (cons 42 0.0) (cons -4 "not>") (cons -4 "and>") (cons -4 "or>")))))
      (if s
        (not (equal (mapcar (function last) (acet-geom-ss-extents-accurate s)) (list 0.0 0.0) 1e-6))
      )
    )
    (prompt "\nEmpty sel set or selected geometry not planar with WCS...")
  )
  (foreach o (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s)))
    (if (= (cdr (assoc 0 (setq ex (entget o)))) "LWPOLYLINE")
      (setq boundary o)
      (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 10 ex)) 0 1)) (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 11 ex)) 0 1))) lil))
    )
  )
  (initget "Yes No")
  (setq ch (getkword "\nDo you want to implement boundary into hatch [Yes/No] <No> : "))
  (mapcar (function set) (list (quote minp) (quote maxp)) (acet-geom-ss-extents-accurate (ssadd boundary)))
  (setq minp (mapcar (function +) (list 0.0 0.0) minp))
  (setq maxp (mapcar (function +) (list 0.0 0.0) maxp))
  (setq w (- (car maxp) (car minp)) h (- (cadr maxp) (cadr minp)))
  (if (= ch "Yes")
    (progn
      (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) minp) (mapcar (function +) (list w 0.0) minp)) lil))
      (setq lil (cons (list (mapcar (function +) (list w 0.0) minp) (mapcar (function +) (list 0.0 0.0) maxp)) lil))
      (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) maxp) (mapcar (function +) (list (- w) 0.0) maxp)) lil))
      (setq lil (cons (list (mapcar (function +) (list (- w) 0.0) maxp) (mapcar (function +) (list 0.0 0.0) minp)) lil))
    )
  )
  (setq lil (reverse lil))
  (initget 6)
  (setq tol (getint "\nSpecify tolerance factor of around rings - <10> : "))
  (if (null tol)
    (setq tol 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 (quote roamablerootprefix)) "support\\") "pat" 1))
  (while (or (not (snvalid (vl-filename-base fn))) (> (strlen (vl-filename-base fn)) 8))
    (prompt "\nSpecified filename not valid, or number of characters greater than 8...")
    (setq fn (getfiled "Specify PATTERN file..." (strcat (getvar (quote roamablerootprefix)) "support\\") "pat" 1))
  )
  (foreach li lil
    (setq a (angle (car li) (cadr li)))
    (setq l (distance (car li) (cadr li)))
    (setq x (caar li) y (cadar li))
    (if (not rr)
      (setq rr (makerecs minp maxp tol))
    )
    (foreach o rr
      (setq ip (offsip (car li) (cadr li) o))
      (cond
        ( (or (equal a 0.0 1e-14) (equal a pi 1e-14) (equal a (* 2 pi) 1e-14))
          (setq g (- (- w l)))
        )
        ( (or (equal a (* 0.5 pi) 1e-14) (equal a (* 1.5 pi) 1e-14))
          (setq g (- (- h l)))
        )
        ( t
          (setq g (- 1000000000)) ;;; giga dash ;;;
        )
      )
      (setq ll (cons (list (cvunit a "radian" "degree") x y (car ip) (cadr ip) l g) ll)) ;;; angle, x-origin, y-origin, delta-x, delta-y, length, dash gap ;;;
      (setq al (cons (cvunit a "radian" "degree") al))
    )
  )
  (initget 6)
  (setq scf (getreal "\nSpecify scale factor for multiplication hatch data <1.0> : "))
  (if (null scf)
    (setq scf 1.0)
  )
  (setq ll (mapcar (function (lambda ( x ) (mapcar (function (lambda ( y ) (* y scf))) x))) ll))
  (setq f (open fn "w"))
  (write-line (strcat "*" (vl-filename-base fn) ", " des) f)
  (setq k -1)
  (foreach li ll
    (setq k (1+ k))
    (if (zerop (last li))
      (write-line (trimlineto80chr (strcat (trim0trailing (rtos (nth k al) 2 6)) "," (trim0trailing (rtos (cadr li) 2 6)) "," (trim0trailing (rtos (caddr li) 2 6)) "," (trim0trailing (rtos (nth 3 li) 2 6)) "," (trim0trailing (rtos (nth 4 li) 2 6)))) f)
      (write-line (trimlineto80chr (strcat (trim0trailing (rtos (nth k al) 2 6)) "," (trim0trailing (rtos (cadr li) 2 6)) "," (trim0trailing (rtos (caddr li) 2 6)) "," (trim0trailing (rtos (nth 3 li) 2 6)) "," (trim0trailing (rtos (nth 4 li) 2 6)) "," (trim0trailing (rtos (nth 5 li) 2 6)) "," (trim0trailing (rtos (nth 6 li) 2 6)))) f)
    )
  )
  (close f)
  (*error* nil)
)

Regards,

HTH. M.R.

sups-rec.pat

Edited July 6 by marko_ribar

July 5

"sups-rec.pat" is a curious pattern file.

I was unable to use it (error message), so I looked at the figures. All lines in the pattern have a pen up distance of 1000000000 (blank dash length).

I prefer my manual method, but it does take me a long time to write the pat file!

July 5

3 hours ago, eldon said:

"sups-rec.pat" is a curious pattern file.

I was unable to use it (error message), so I looked at the figures. All lines in the pattern have a pen up distance of 1000000000 (blank dash length).

I prefer my manual method, but it does take me a long time to write the pat file!

That is why I said "I cheated"... Actually real *.pat file should have only 247 lines + heading (filename+description) + blank line at the end... But, unfortunately I don't know how to create that file to make pattern behave rectangular - with squares we have that code by Lanny Schiele which is great...

July 6

Also, another cheat, but this time very quick generation of pattern... This version uses dot approximation of line entities... Hatch pattern is somewhat smaller (51 points per line - instead of previously 481 lines per 247 line each)... If you zoom only too much, you can see dots, but if you are with zoomings like 4x4 rectangular boundary - you'll see sign of superman like it was drawn linearily...

So here is mod. of Lanny Schiele code :

;;;CADALYST 10/05 Tip 2065: HatchMaker.lsp	Hatch Maker	(c) 2005 Larry Schiele

;;;* ======   B E G I N   C O D E   N O W    ======   
;;;* HatchMaker.lsp written by Lanny Schiele at TMI Systems Design Corporation
;;;* Lanny.Schiele@tmisystems.com
;;;* Tested on AutoCAD 2002 & 2006. -- does include a 'VL' function -- should work on Acad2000 on up.
;;;
;;;* Modified by M.R. to make hatchings with points that follow lines to make hatchings acceptable for rectangular boundary.

(defun C:SaveHatch-rectangle
  ( / round    dxf      ListToFile 
      SelSet   SelSetSize ssNth  fuzz
      Ent      EntInfo  EntType  pt1 pt2
      Dist     a        DeltaX   DeltaY
      DimZin   lw       minp     maxp
      ww       hh       pt       k n dx
  )

;;;* BEGIN NESTED FUNCTIONS

  (defun round (num)
    (if (>= (- num (fix num)) 0.5)
      (fix (1+ num))
      (fix num)
    )
  )

  (defun dxf (code EnameOrElist / VarType)
    (setq VarType (type EnameOrElist))
    (if (= VarType (read "ENAME"))
      (cdr (assoc code (entget EnameOrElist)))
      (cdr (assoc code EnameOrElist))
    )
  )

  (defun ListToFile (TextList FileName DoOpenWithNotepad AsAppend / TextItem File RetVal)
    (if (setq File (open FileName (if AsAppend "a" "w")))
      (progn
        (foreach TextItem TextList
          (write-line TextItem File)
        )
        (setq File (close File))
        (if DoOpenWithNotepad
          (startapp "notepad" FileName)
        )
      )
    )
    (FindFile FileName)
  )

  (textscr)
  (getstring "\nHit [ENTER] to continue...")

  (princ "\nSelect pattern of lines and/or points for new hatch pattern along with bounding lwpolyline boundary...")
  (while (not (setq SelSet (ssget (list (cons -4 "<or") (cons 0 "LINE,POINT") (cons -4 "<and") (cons 0 "LWPOLYLINE") (cons 90 4) (cons -4 "&=") (cons 70 1) (cons -4 "<not") (cons -4 "<>") (cons 42 0.0) (cons -4 "not>") (cons -4 "and>") (cons -4 "or>"))))))
  (initget 6)
  (setq fuzz (cond ( (getdist "\nPick or specify fuzz distance between 2 adjacent points <0.005> : ") ) (0.005)))
  (foreach o (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex SelSet)))
    (if (= (cdr (assoc 0 (entget o))) "LWPOLYLINE")
      (setq lw o)
    )
  )
  (ssdel lw SelSet)
  (vla-getboundingbox (vlax-ename->vla-object lw) (quote minp) (quote maxp))
  (mapcar (function set) (list (quote minp) (quote maxp)) (mapcar (function safearray-value) (list minp maxp)))
  (setq ww (- (car maxp) (car minp)) hh (- (cadr maxp) (cadr minp)))
  (setq ssNth 0
        SelSetSize (sslength SelSet)
        DimZin (getvar "DIMZIN")
  )
  (setvar "DIMZIN" 11)
  (if (> SelSetSize 0)
    (princ "\nAnalyaing entities...")
  )
  (while (< ssNth SelSetSize)
    (setq Ent (ssname SelSet ssNth)
          EntInfo (entget Ent)
          EntType (dxf 0 EntInfo)
          ssNth (+ ssNth 1)
    )
    (cond
      ( (= EntType "POINT")
        (setq pt1 (dxf 10 EntInfo)
              FileLine (strcat "0," (rtos (car pt1) 2 8) "," (rtos (cadr pt1) 2 8) "," (rtos ww 2 8) "," (rtos hh 2 8) ",0,-" (rtos ww 2 8))
        )
        (princ (strcat "\n" FileLine))
        (setq FileLines (cons FileLine FileLines))
      )
      ( (= EntType "LINE")
        (setq pt1 (dxf 10 EntInfo)
              pt2 (dxf 11 EntInfo)
              Dist (distance pt1 pt2)
              a (angle pt1 pt2)
        )
        (setq n (fix (/ Dist fuzz)))
        (if (= n 0)
          (setq n 1)
        )
        (setq dx (/ Dist n))
        (setq k -1)
        (repeat (1+ n)
          (setq k (1+ k))
          (setq pt (polar pt1 a (* dx k)))
          (setq FileLine (strcat "0," (rtos (car pt) 2 8) "," (rtos (cadr pt) 2 8) "," (rtos ww 2 8) "," (rtos hh 2 8) ",0,-" (rtos ww 2 8)))
          (setq FileLines (cons FileLine FileLines))
        )
      )
      ( (princ (strcat "\n * * *  Invalid entity " EntType " omitted."))
      )
    )
  )
  (setvar "DIMZIN" DimZin)
  (if
    (and
      FileLines
      (setq HatchDescr (getstring T "\nBriefly describe this hatch pattern: "))
      (setq FileName (getfiled "Hatch Pattern File" (strcat (getvar (quote roamablerootprefix)) "support\\") "pat" 1))
    )
    (progn
      (if (= HatchDescr "")
        (setq HatchDescr "Custom hatch pattern")
      )
      (setq HatchName (vl-filename-base FileName)
            FileLines (cons (strcat "*" HatchName "," HatchDescr) (reverse FileLines))
      )
      (princ "\n============================================================")
      (princ (strcat "\nPlease wait while the hatch file is created...\n"))
      (ListToFile FileLines FileName nil nil)
      (while (not (findfile FileName))) ; (vl-cmdf "delay" 1500) ; delay required so file can be created and found (silly, but req.)
      (if (findfile FileName)
        (princ (strcat "\nHatch pattern '" HatchName "' is ready to use!"))
        (progn
          (princ "\nUnable to create hatch pattern file:")
          (princ (strcat "\n  " FileName))
        )
      )
    )
    (princ (if FileLines "\nCancelled." "\nUnable to create hatch pattern from selected entities."))
  )
  (princ)
)
;|
(princ "\n ************************************************************** ")
(princ "\n**                                                            **")
(princ "\n*  HatchMaker.lsp written by Lanny Schiele -- enjoy!           *")
(princ "\n*                                                              *")
(princ "\n*  Type in DRAWHATCH to have the environment created to draw.  *")
(princ "\n*  Type in SAVEHATCH to save the pattern you created.          *")
(princ "\n**                                                            **")
(princ "\n ************************************************************** ")
(princ)
|;

sups-rec-hatched-4x4.dwg sups-rec.pat

Edited July 7 by marko_ribar

July 7

This code is for rectangular hatchings, but only for orthogonal lines... So with this routine, it's all covered AFAIK with hatchings...

So long from me...

Regards,

HTH.

M.R.

(defun c:savehatch-from-ortho-lins-inside-rec-bound ( / *error* trim0trailing trimlineto80chr acet-geom-ss-extents-accurate cmde s boundary ch minp maxp w h ex lil des fn a x y ip l g ll f al scf )

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

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

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

  (defun trimlineto80chr ( str / lst )
    (setq lst (vl-string->list str))
    (setq lst (reverse lst))
    (while (> (length lst) 80)
      (setq lst (cdr lst))
    )
    (setq lst (reverse lst))
    (vl-list->string lst)
  )

  (defun acet-geom-ss-extents-accurate ( ss / layers i lck e layer minp maxp minl maxl )
    (if ss
      (progn
        (setq layers (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))))
        (repeat (setq i (sslength ss))
          (setq lck nil)
          (setq e (ssname ss (setq i (1- i))))
          (if (= (vla-get-lock (vla-item layers (setq layer (vla-get-layer (vlax-ename->vla-object e))))) :vlax-true)
            (progn
              (vla-put-lock (vla-item layers layer) :vlax-false)
              (setq lck t)
            )
          )
          (vla-transformby (vlax-ename->vla-object e) (vlax-tmatrix (append (mapcar (function (lambda ( vector origin ) (append (trans vector 1 0 t) (list origin)))) (list (list 1.0 0.0 0.0) (list 0.0 1.0 0.0) (list 0.0 0.0 1.0)) (trans (list 0.0 0.0 0.0) 0 1)) (list (list 0.0 0.0 0.0 1.0)))))
          (vla-getboundingbox (vlax-ename->vla-object e) (quote minp) (quote maxp))
          (vla-transformby (vlax-ename->vla-object e) (vlax-tmatrix (append (mapcar (function (lambda ( vector origin ) (append (trans vector 0 1 t) (list origin)))) (list (list 1.0 0.0 0.0) (list 0.0 1.0 0.0) (list 0.0 0.0 1.0)) (trans (list 0.0 0.0 0.0) 1 0)) (list (list 0.0 0.0 0.0 1.0)))))
          (if lck
            (vla-put-lock (vla-item layers layer) :vlax-true)
          )
          (mapcar (function set) (list (quote minp) (quote maxp)) (mapcar (function safearray-value) (list minp maxp)))
          (setq minl (cons minp minl) maxl (cons maxp maxl))
        )
        (list (apply (function mapcar) (cons (function min) minl)) (apply (function mapcar) (cons (function max) maxl)))
      )
    )
  )

  (setq cmde (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (alert "Draw boundary rectangle boundary and hatching geometry (orthogonal 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 made of ORTHOGONAL LINES...")
      (not (setq s (ssget (list (cons -4 "<or") (cons 0 "LINE") (cons -4 "<and") (cons 0 "LWPOLYLINE") (cons -4 "<not") (cons -4 "<>") (cons 42 0.0) (cons -4 "not>") (cons -4 "and>") (cons -4 "or>")))))
      (if s
        (not (equal (mapcar (function last) (acet-geom-ss-extents-accurate s)) (list 0.0 0.0) 1e-6))
      )
    )
    (prompt "\nEmpty sel set or selected geometry not planar with WCS...")
  )
  (foreach o (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s)))
    (if (= (cdr (assoc 0 (setq ex (entget o)))) "LWPOLYLINE")
      (setq boundary o)
      (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 10 ex)) 0 1)) (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 11 ex)) 0 1))) lil))
    )
  )
  (initget "Yes No")
  (setq ch (getkword "\nDo you want to implement boundary into hatch [Yes/No] <No> : "))
  (mapcar (function set) (list (quote minp) (quote maxp)) (acet-geom-ss-extents-accurate (ssadd boundary)))
  (setq minp (mapcar (function +) (list 0.0 0.0) minp))
  (setq maxp (mapcar (function +) (list 0.0 0.0) maxp))
  (setq w (- (car maxp) (car minp)) h (- (cadr maxp) (cadr minp)))
  (if (= ch "Yes")
    (progn
      (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) minp) (mapcar (function +) (list w 0.0) minp)) lil))
      (setq lil (cons (list (mapcar (function +) (list w 0.0) minp) (mapcar (function +) (list 0.0 0.0) maxp)) lil))
      (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) maxp) (mapcar (function +) (list (- w) 0.0) maxp)) lil))
      (setq lil (cons (list (mapcar (function +) (list (- w) 0.0) maxp) (mapcar (function +) (list 0.0 0.0) minp)) 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 (quote roamablerootprefix)) "support\\") "pat" 1))
  (while (or (not (snvalid (vl-filename-base fn))) (> (strlen (vl-filename-base fn)) 8))
    (prompt "\nSpecified filename not valid, or number of characters greater than 8...")
    (setq fn (getfiled "Specify PATTERN file..." (strcat (getvar (quote roamablerootprefix)) "support\\") "pat" 1))
  )
  (foreach li lil
    (setq a (angle (car li) (cadr li)))
    (setq l (distance (car li) (cadr li)))
    (setq x (caar li) y (cadar li))
    (cond
      ( (or (equal a 0.0 1e-14) (equal a pi 1e-14) (equal a (* 2 pi) 1e-14))
        (setq ip (list 0.0 h))
        (setq g (- (- w l)))
      )
      ( (or (equal a (* 0.5 pi) 1e-14) (equal a (* 1.5 pi) 1e-14))
        (setq ip (list 0.0 w))
        (setq g (- (- h l)))
      )
      ( t
        (prompt "\nYou selected non orthogonal line... This routine works only with orthogonal lines... Quitting...")
        (exit)
      )
    )
    (setq ll (cons (list (cvunit a "radian" "degree") x y (car ip) (cadr ip) l g) ll)) ;;; angle, x-origin, y-origin, delta-x, delta-y, length, dash gap ;;;
    (setq al (cons (cvunit a "radian" "degree") al))
  )
  (initget 6)
  (setq scf (getreal "\nSpecify scale factor for multiplication hatch data <1.0> : "))
  (if (null scf)
    (setq scf 1.0)
  )
  (setq ll (mapcar (function (lambda ( x ) (mapcar (function (lambda ( y ) (* y scf))) x))) ll))
  (setq f (open fn "w"))
  (write-line (strcat "*" (vl-filename-base fn) ", " des) f)
  (setq k -1)
  (foreach li ll
    (setq k (1+ k))
    (if (zerop (last li))
      (write-line (trimlineto80chr (strcat (trim0trailing (rtos (nth k al) 2 6)) "," (trim0trailing (rtos (cadr li) 2 6)) "," (trim0trailing (rtos (caddr li) 2 6)) "," (trim0trailing (rtos (nth 3 li) 2 6)) "," (trim0trailing (rtos (nth 4 li) 2 6)))) f)
      (write-line (trimlineto80chr (strcat (trim0trailing (rtos (nth k al) 2 6)) "," (trim0trailing (rtos (cadr li) 2 6)) "," (trim0trailing (rtos (caddr li) 2 6)) "," (trim0trailing (rtos (nth 3 li) 2 6)) "," (trim0trailing (rtos (nth 4 li) 2 6)) "," (trim0trailing (rtos (nth 5 li) 2 6)) "," (trim0trailing (rtos (nth 6 li) 2 6)))) f)
    )
  )
  (close f)
  (*error* nil)
)

Edited July 7 by marko_ribar

September 4

On 7/7/2024 at 12:43 AM, marko_ribar said:

So here is mod. of Lanny Schiele code :

Hi again,

I've been trying to figure out why AutoCADs' preview looks next to useless (and that's been very generous). See the attached example hatch pattern and the original drawing file also.

The preview looks like this

What does bricsCADs' preview look like?

I have the hatch drawn in a 1x1 square with a rounding of 0.01.

It should half resemble this 1x1 square, I would of thought.

Stone Cobble 01.dwg Stone Cobble 01.pat

Edited September 4 by 3dwannab

September 5

In Bricscad the preview is a Black rectang, it may be due to the pattern using dots rather than lines.

The pattern it self works, but I know from past experience doing lines as dots can massively slow down a dwg.

Edited September 5 by BIGAL

September 5

Dots. Oh. The pattern is drawn as lines. Am I missing something?

September 5

2 hours ago, 3dwannab said:

Dots. Oh. The pattern is drawn as lines. Am I missing something?

If you look at the pattern file in a text editor, all 4732 lines of the definition format have an angle (first number of a definition line) of 0 degrees and a length (sixth number of a definition line) of 0.

There are no lines and if you zoom into the hatch pattern you will see the dots

Edited September 5 by eldon
removed picture

September 5

If you want lines only, the pattern consists of 8 rows of cobbles with 6 cobbles in each row. Each cobble is made up with 8 lines, so the definition file should have 384 lines.

Incidentally, the file name posted above fails in my version of AutoCAD because there are spaces in the file name. Perhaps it is different in Briscad?

I attach a better picture of the hatch dots.

Sign In

make pat files

Recommended Posts

marko_ribar

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

marko_ribar

TerryDotson

marko_ribar

Posted Images

3dwannab

3dwannab

marko_ribar

marko_ribar

marko_ribar

3dwannab

marko_ribar

marko_ribar

3dwannab

marko_ribar

eldon

marko_ribar

marko_ribar

marko_ribar

3dwannab

BIGAL

3dwannab

eldon

eldon

Join the conversation

marko_ribar

TerryDotson

marko_ribar

Tutorials

Forums

Activity