Bhatch，用lisp，请帮忙！乐筑天下 - Powered by Discuz! Archiver

liuhaixin88 发表于 2022-7-5 23:07:21

Bhatch，用lisp，请帮忙！

大家好，我需要帮助。
使用LISP执行此操作：

1.指定四个点。
2、在此区域使用“bhatch”。缩放可以是动态的。
3、去掉边框。

谢谢你的帮助！

Tharwat 发表于 2022-7-5 23:17:48

试试这个，让我知道。

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

liuhaixin88 发表于 2022-7-5 23:19:56

谢谢你，比格尔，谢谢你的建议！

Tharwat 发表于 2022-7-5 23:25:04

非常感谢你，塔瓦，

完美的代码。你是最棒的！

liuhaixin88 发表于 2022-7-5 23:31:08

太好了，随时欢迎你。

BIGAL 发表于 2022-7-5 23:36:19

BIGAL 发表于 2022-7-5 23:44:35

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

Tharwat 发表于 2022-7-5 23:49:51

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 ( :"))) (progn (setq v nil a p i 1 sc1.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)

liuhaixin88 发表于 2022-7-5 23:55:10

Thank you,BIGAL,Thank you for your suggestion!

liuhaixin88 发表于 2022-7-5 23:59:45

Thank you very much, Tharwat,

Perfect code. You're the greatest!

页: [1] 2

乐筑天下's Archiver

Bhatch，用lisp，请帮忙！