[编程交流] 这个代码很好，我喜欢

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