[编程交流] Bhatch，用lisp，请帮忙！

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

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