Bhatch,use lisp,please help!

Hello everyone，I need some help.

Use LISP to do this:

1. Specify four points.

2. use"bhatch" in this region.Scale can dynamic.

3. Remove the border.

Thank for help me!

Try this and let me know .

(defun c:Test (/ p a i sc l 1p e pl h gr)
 ;;    Tharwat 10. Apr. 2014         ;;
 (if
   (eq
     4
     (logand 4
             (cdr
               (assoc 70 (entget (tblobjname "LAYER" (getvar 'CLAYER))))
             )
     )
   )
    (alert "Current layer is LOCKED ! Unlock and Try again .")
    (if (setq p (getpoint "\n Specify point < 1 > :"))
      (progn
        (setq a  p
              i  1
              sc 1.0
              l  (cons p l)
        )
        (while (/= (length l) 4)
          (setq
            1p (getpoint
                 p
                 (strcat "\n Next point < "
                         (itoa (setq i (1+ i)))
                         " > :"
                 )
               )
          )
          (setq l (cons 1p l)
                p 1p
          )
        )
        (setq
          e (entmakex
              (append (list '(0 . "LWPOLYLINE")
                            '(100 . "AcDbEntity")
                            '(100 . "AcDbPolyline")
                            '(70 . 1)
                            '(90 . 4)
                           )
                      (mapcar '(lambda (u) (cons 10 u)) (cons a l))
              )
            )
        )
        (setq pl (entlast))
        (command "_.-hatch" "S" e "" "P" "ANSI37" 1.0 0.0 "")
        (setq h (entlast))
        (vla-put-AssociativeHatch
          (setq v (vlax-ename->vla-object h))
          :vlax-false
        )
        (entdel e)
        (princ "\n Type [+,-] to change Pattern Scale :")
        (if (not (eq pl h))
          (while (or (eq (car (setq gr (grread t 13 0))) 5)
                     (member (cadr gr) '(43 61 45))
                 )
            (redraw)
            (if (and (eq (car gr) 2)
                     (member (cadr gr) '(43 61 45))
                )
              (vla-put-patternscale
                v
                (if (eq (cadr gr) 45)
                  (progn
                    (if (<= (setq sc (- sc 0.5)) 0.)
                      (setq sc 0.5)
                      sc
                    )
                  )
                  (setq sc (+ sc 0.5))
                )
              )
            )
          )
        )
      )
    )
 )
 (princ)
)(vl-load-com)

Try this and let me know .

(defun c:Test (/ p a i l 1p e)
 ;;    Tharwat 10. Apr. 2014         ;;
 (if
   (eq
     4
     (logand 4
             (cdr
               (assoc 70 (entget (tblobjname "LAYER" (getvar 'CLAYER))))
             )
     )
   )
    (alert "Current layer is LOCKED ! Unlock and Try again .")
    (if (setq p (getpoint "\n Specify first point :"))
      (progn
        (setq a p
              i 1
              l (cons p l)
        )
        (while (/= (length l) 4)
          (setq
            1p (getpoint
                 p
                 (strcat "\n Next point < "
                         (itoa (setq i (1+ i)))
                         " > :"
                 )
               )
          )
          (setq l (cons 1p l)
                p 1p
          )
        )
        (setq
          e (entmakex
              (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity")
                            '(100 . "AcDbPolyline") '(70 . 1) '(90 . 4))
                      (mapcar '(lambda (u) (cons 10 u)) (cons a l))
              )
            )
        )
        (command "_.-hatch" "S" e "" "P" "ANSI37" 1.0 0.0 "")
        (entdel e)
      )
    )
 )
 (princ)
)

Beautifully!Thank you!but I want scale dynamic , or use "+"&"－"key to adjust scale. thank you very much!tharwat.

Beautifully!Thank you!but I want scale dynamic , or use "+"&"－"key to adjust scale. thank you very much!tharwat.

You're welcome .

I just modified the routine to meet your new requirements .

Try it and let me know .

You're welcome .

 

I just modified the routine to meet your new requirements .

 

Try it and let me know .

Thank you,Tharwat, Your codes is always reassuring！ Thanks so much!

I'm still a little small request:

Add a option, can use "ANSI31" Bhatch, if choose "ANSI31" , must Adjust the "Angle" and "Scale" (ANSI37 only adjust scale ). "angle" only two kinds, 35 and 135.

Tharwat if you decide to add more to your code maybe rather than hard code the scale and angle put these in a while that allows you to keep changing till happy a none answer would exit the while.

Read the above again the + - would be a good way say 5 or 10 degrees.

Now wheres that pop up pick hatch dialouge.

Here is a list select option for basicly any one wanting to pick from a list, thanks to AlanJt for original code. My menu would be ^c^c^p(load "listselect")(Load "Hatcher")

; By Alan H Apr 2014
;select from list box 
; thanks to AlanJT for list select
(setq lst (list "Ansi31" "Ansi32" "Net" "dots"))

(setq lstpick (car (AT:ListSelect
               "Set hatch pattern"
               "Select style"
               10
               10
               "false"
               (vl-sort lst) '<)
            )
            )
)
(princ lstpick)

 ;; List Select Dialog (Temp DCL list box selection, based on provided list)
 ;; title - list box title
 ;; label - label for list box
 ;; height - height of box
 ;; width - width of box
 ;; multi - selection method ["true": multiple, "false": single]
 ;; lst - list of strings to place in list box
 ;; Alan J. Thompson, 09.23.08 / 05.17.10 (rewrite)
(defun AT:ListSelect (title label height width multi lst / fn fo d item f)
 (setq fo (open (setq fn (vl-filename-mktemp "" "" ".dcl")) "w"))
 (foreach x (list (strcat "list_select : dialog { label = \"" title "\"; spacer;")
                  (strcat ": list_box { label = \"" label "\";" "key = \"lst\";")
                  (strcat "allow_accept = true; height = " (vl-princ-to-string height) ";")
                  (strcat "width = " (vl-princ-to-string width) ";")
                  (strcat "multiple_select = " multi "; } spacer; ok_cancel; }")
            )
   (write-line x fo)
 )
 (close fo)
 (new_dialog "list_select" (setq d (load_dialog fn)))
 (start_list "lst")
 (mapcar (function add_list) lst)
 (end_list)
 (setq item (set_tile "lst" "0"))
 (action_tile "lst" "(setq item $value)")
 (setq f (start_dialog))
 (unload_dialog d)
 (vl-file-delete fn)
 (if (= f 1)
   ((lambda (s / i s l)
      (while (setq i (vl-string-search " " s))
        (setq l (cons (nth (atoi (substr s 1 i)) lst) l))
        (setq s (substr s (+ 2 i)))
      )
      (reverse (cons (nth (atoi s) lst) l))
    )
     item
   )
 )
)

I prepared a video for the following routine but it did uploaded as an image and not as a .gif file .

Try this routine and let me know how things going on with you .

(defun c:Test (/ *error* dlg p a i l 1p sc e pl h gr rot r)
 ;;    Author : Tharwat Al Shoufi 14. Apr. 2014         ;;
 (defun *error* (msg)
   (if (< id 0)
     (unload_dialog id)
   )
   (if (and d (setq d (findfile d)))
     (vl-file-delete d)
   )
   (if (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")
     (princ msg)
     (princ (strcat "\nError: " msg))
   )
   (princ)
 )
 ;;                    ;;
 (defun dlg (h / d o id head tail go back)
   (if (and (setq d (vl-filename-mktemp nil nil ".dcl")) (setq o (open d "w")))
     (progn (setq head "test : dialog { label = \"Hatch Control\";"
                  tail ": button { label = \"Exit\"; key = \"esc\"; width = 12; height = 2; fixed_width = true; alignment = centered;
            is_default = true; is_cancel = true;}"
            )
            (if h
              (write-line
                (strcat
                  head ": button { label = \"ANSI37\"; key = \"i37\"; width = 10; height = 2.5;} spacer; "
                  ": button { label = \"ANSI31\"; key = \"i31\"; width = 10; height = 2.5;} spacer; " tail "}"
                 )
                o
              )
              (write-line
                (strcat
                  head ": boxed_column { label = \"Controls\"; : text { label = \"Scale\";}"
                  ": row { : button { label = \"+\"; key = \"isc\"; width = 2;}"
                  ": button { label = \"-\"; key = \"dsc\"; width = 2;}}" "spacer; : text { label = \"Rotation\";}"
                  ": row { : button { label = \"+\"; key = \"iro\"; width = 2;}"
                  ": button { label = \"-\"; key = \"dro\"; width = 2;}}} spacer;" tail "}"
                 )
                o
              )
            )
            (close o)
     )
   )
   (if (or (not d)
           (> 0 (setq id (load_dialog d)))
           (not (new_dialog
                  "test"
                  id
                  ""
                  (if *loc*
                    *loc*
                    '(-1 -1)
                  )
                )
           )
       )
     (progn (if (< id 0)
              (unload_dialog id)
            )
            (if (and d (setq d (findfile d)))
              (vl-file-delete d)
            )
     )
     (progn
       (action_tile "i37" "(setq go \"ANSI37\") (done_dialog)")
       (action_tile "i31" "(setq go \"ANSI31\") (done_dialog)")
       (if (eq *pat* "ANSI37")
         (mapcar '(lambda (u) (mode_tile u 1)) (list "iro" "dro"))
       )
       (action_tile
         "iro"
         "(if (>= (setq rot (+ rot (/ pi 12.))) (+ pi pi))
                              (setq rot (/ pi 12.)) rot)(setq r t *loc* (done_dialog))"
       )
       (action_tile
         "dro"
         "(if (>= (setq rot (- rot (/ pi 12.))) (+ pi pi))
                              (setq rot (/ pi 12.)) rot)(setq r t *loc* (done_dialog))"
       )
       (action_tile "isc" "(setq sc (+ sc 0.5) back t *loc* (done_dialog))")
       (action_tile
         "dsc"
         "(if (<= (setq sc (- sc 0.5)) 0.)(setq sc 0.5) sc)(setq back t *loc* (done_dialog))"
       )
       (action_tile "esc" "(setq back nil r nil)(done_dialog)")
       (start_dialog)
       (unload_dialog id)
       (vl-file-delete d)
     )
   )
   (cond ((and back) (vla-put-patternscale v sc) (vla-update v) (dlg nil))
         ((and r) (vla-put-PatternAngle v rot) (vla-update v) (dlg nil))
         (t nil)
   )
   go
 )
 ;;                        ;;
 (if (eq 4 (logand 4 (cdr (assoc 70 (entget (tblobjname "LAYER" (getvar 'CLAYER)))))))
   (alert "Current layer is LOCKED ! Unlock and Try again .")
   (if (and (setq *pat* (dlg t)) (setq p (getpoint "\n Specify point < 1 > :")))
     (progn (setq v   nil
                  a   p
                  i   1
                  sc  1.0
                  rot 0.
                  l   (cons p l)
            )
            (while (/= (length l) 4)
              (setq 1p (getpoint p (strcat "\n Next point < " (itoa (setq i (1+ i))) " > :")))
              (setq l (cons 1p l)
                    p 1p
              )
            )
            (setq e (entmakex
                      (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(70 . 1) '(90 . 4))
                              (mapcar '(lambda (u) (cons 10 u)) (cons a l))
                      )
                    )
            )
            (setq pl (entlast))
            (command "_.-hatch" "S" e "" "P" *pat* 1.0 0.0 "")
            (setq h (entlast))
            (vla-put-AssociativeHatch (setq v (vlax-ename->vla-object h)) :vlax-false)
            (entdel e)
            (if (not (eq pl h))
              (dlg nil)
            )
     )
   )
 )
 (princ)
)
(vl-load-com)

Here is a list select option for basicly any one wanting to pick from a list, thanks to AlanJt for original code. My menu would be ^c^c^p(load "listselect")(Load "Hatcher")

 

Thank you,BIGAL,Thank you for your suggestion!

I prepared a video for the following routine but it did uploaded as an image and not as a .gif file .

 

Try this routine and let me know how things going on with you .

 

Thank you very much, Tharwat,

Perfect code. You're the greatest!

Thank you very much, Tharwat,

 

Perfect code. You're the greatest!

Excellent , you are welcome anytime .

I prepared a video for the following routine but it did uploaded as an image and not as a .gif file .

 

Try this routine and let me know how things going on with you .

 

 
Nice to see you again ,Tharwat, Can you extend to me, please！
 
I don't need pick 4 point to hatch, only pick one point, like Internal command: bhatch , I only need ANSI131 & ANSI137 too.