Lisp routine for hatch pattern creation by selecting entities

[sovby254640]

I'm looking for a routine to create a hatch pattern by selecting lines. I found one called hatchmaker that does this but it needs to be inside of a 1"x1" box. My pattern is a tile pattern that is 36" wide x 6" high. The second row will be 1/3 offset @ 12". Is there a routine out there that will create this pattern?

[marko_ribar]

Can you post a DWG with such a sample of HATCH pattern...

[sovby254640]

Can you post a DWG with such a sample of HATCH pattern...

Here is the file unless somebody knows the code to put in the pat file. Ive always struggled a bit with hatch patterns. What i want is a 36" wide by 6" high pattern with the vertical line offset 12"

[marko_ribar]

Here you are... Specify that running is by 1/3 of width and choose option - left... Experiment a while with various options for this routine...

(defun c:hm-dstrun ( / ss ch1 ch2 apth asupppth f *** scal w h n m )

  (vl-load-com)

  (prompt "\nHATCH MAKE")
  (print)
  (setenv "MaxHatch" "10000000")
  (prompt "\nSelect boundary...")
  (setq ss (ssget))
  (print)
  (if (null *w*)
    (progn
      (initget 7)
      (setq w (getdist "\nPick or specify width of plate : "))
      (setq *w* w)
    )
    (progn
      (initget 6)
      (setq w (getdist (strcat "\nPick or specify width plate <" (rtos *w* 2 8) "> : ")))
      (if (null w)
        (setq w *w*)
        (setq *w* w)
      )
    )
  )
  (if (null *h*)
    (progn
      (initget 7)
      (setq h (getdist "\nPick or specify height of plate : "))
      (setq *h* h)
    )
    (progn
      (initget 6)
      (setq h (getdist (strcat "\nPick or specify height of plate <" (rtos *h* 2 8) "> : ")))
      (if (null h)
        (setq h *h*)
        (setq *h* h)
      )
    )
  )
  (initget 7)
  (setq n (getint "\nSpecify how many times is width of plate larger than running distance : "))
  (initget 1 "Left Right")
  (setq ch1 (getkword "\nPattern is running from [Left/Right] : "))
  (initget 1 "Yes No")
  (setq ch2 (getkword "\nPattern is with mortar [Yes/No] : "))
  (if (eq ch2 "Yes")
    (progn
      (alert "Width and height of plates will be reduced according to mortar width")
      (if (null *m*)
        (progn
          (initget 7)
          (setq m (getdist "\nPick or specify width of mortar of square pattern : "))
          (setq *m* m)
        )
        (progn
          (initget 6)
          (setq m (getdist (strcat "\nPick or specify width of mortar of square pattern <" (rtos *m* 2 8) "> : ")))
          (if (null m)
            (setq m *m*)
            (setq *m* m)
          )
        )
      )
    )
  )
  (setq apth (vla-get-path (vlax-get-acad-object)))
  (setq asupppth (strcat apth "\\support"))
  (setq f (open (strcat asupppth "\\hm-dstrun.pat") "w"))
  (write-line "*HM-DSTRUN,HM-DSTRUN" f)
  (cond
    ( (and (eq ch1 "Left") (eq ch2 "No"))
      (write-line (strcat "0,0,0," (rtos (/ w n) 2 8) "," (rtos h 2 8) "," (rtos w 2 8)) f)
      (write-line (strcat "0,0," (rtos h 2 8) "," (rtos (/ w n) 2 8) "," (rtos h 2 8) "," (rtos w 2 8)) f)
      (write-line (strcat "90,0,0," (rtos h 2 8) "," (rtos (- (/ w n)) 2 8) "," (rtos h 2 8) "," (rtos (- (* (1- n) h)) 2 8)) f)
      (write-line (strcat "90," (rtos w 2 8) ",0," (rtos h 2 8) "," (rtos (- (/ w n)) 2 8) "," (rtos h 2 8) "," (rtos (- (* (1- n) h)) 2 8)) f)
    )
    ( (and (eq ch1 "Left") (eq ch2 "Yes"))
      (write-line (strcat "0," (rtos (/ m 2) 2 8) "," (rtos (/ m 2) 2 8) "," (rtos (/ w n) 2 8) "," (rtos h 2 8) "," (rtos (- w m) 2 8) "," (rtos (- m) 2 8)) f)
      (write-line (strcat "0," (rtos (/ m 2) 2 8) "," (rtos (+ (/ m 2) (- h m)) 2 8) "," (rtos (/ w n) 2 8) "," (rtos h 2 8) "," (rtos (- w m) 2 8) "," (rtos (- m) 2 8)) f)
      (write-line (strcat "90," (rtos (/ m 2) 2 8) "," (rtos (/ m 2) 2 8) "," (rtos h 2 8) "," (rtos (- (/ w n)) 2 8) "," (rtos (- h m) 2 8) "," (rtos (- (+ (* (1- n) (- h m)) (* n m))) 2 8)) f)
      (write-line (strcat "90," (rtos (+ (/ m 2) (- w m)) 2 8) "," (rtos (/ m 2) 2 8) "," (rtos h 2 8) "," (rtos (- (/ w n)) 2 8) "," (rtos (- h m) 2 8) "," (rtos (- (+ (* (1- n) (- h m)) (* n m))) 2 8)) f)
    )

    ( (and (eq ch1 "Right") (eq ch2 "No"))
      (write-line (strcat "0,0,0," (rtos (- (/ w n)) 2 8) "," (rtos h 2 8) "," (rtos w 2 8)) f)
      (write-line (strcat "0,0," (rtos h 2 8) "," (rtos (- (/ w n)) 2 8) "," (rtos h 2 8) "," (rtos w 2 8)) f)
      (write-line (strcat "90,0,0," (rtos h 2 8) "," (rtos (/ w n) 2 8) "," (rtos h 2 8) "," (rtos (- (* (1- n) h)) 2 8)) f)
      (write-line (strcat "90," (rtos w 2 8) ",0," (rtos h 2 8) "," (rtos (/ w n) 2 8) "," (rtos h 2 8) "," (rtos (- (* (1- n) h)) 2 8)) f)
    )
    ( (and (eq ch1 "Right") (eq ch2 "Yes"))
      (write-line (strcat "0," (rtos (/ m 2) 2 8) "," (rtos (/ m 2) 2 8) "," (rtos (- (/ w n)) 2 8) "," (rtos h 2 8) "," (rtos (- w m) 2 8) "," (rtos (- m) 2 8)) f)
      (write-line (strcat "0," (rtos (/ m 2) 2 8) "," (rtos (+ (/ m 2) (- h m)) 2 8) "," (rtos (- (/ w n)) 2 8) "," (rtos h 2 8) "," (rtos (- w m) 2 8) "," (rtos (- m) 2 8)) f)
      (write-line (strcat "90," (rtos (/ m 2) 2 8) "," (rtos (/ m 2) 2 8) "," (rtos h 2 8) "," (rtos (/ w n) 2 8) "," (rtos (- h m) 2 8) "," (rtos (- (+ (* (1- n) (- h m)) (* n m))) 2 8)) f)
      (write-line (strcat "90," (rtos (+ (/ m 2) (- w m)) 2 8) "," (rtos (/ m 2) 2 8) "," (rtos h 2 8) "," (rtos (/ w n) 2 8) "," (rtos (- h m) 2 8) "," (rtos (- (+ (* (1- n) (- h m)) (* n m))) 2 8)) f)
    )
  )
  (close f)
  (initget 1 "Yes No")
  (setq *** (getkword "\nAssociative hatch [Yes/No] ? "))
  (initget 6)
  (setq scal (getreal "\nScale factor of hatch <1.0> : "))
  (if (null scal) 
    (setq scal 1)
  )
  (command "_.-BHATCH" "_S" ss "" "_A" "_A" *** "" "_P" "HM-DSTRUN" scal "" "")
  (princ)
)

HTH, M.R.

[sovby254640]

Thanks, very much appreciated