社区 › Auto Lisp › 填充图案填充LISP

afwjlk2 发表于 2022-7-5 22:25:54

填充图案填充LISP

在论坛中找到了这个。有人能清理一下吗？提前谢谢你。
 
;;-------------------Solid Hatch}-----------------------;;
;;                                                      ;;
;;            Creates a solid hatch                   ;;
;;      with respect to the color of the objects      ;;
;;------------------------------------------------------;;

(defun c:Sldhtch (/ *error* v l ss doc)

(defun C:hatchcol2 ( / obj hatcol pt)
(vl-load-com)
(princ "\nPlease pick object for color")
(setq obj (car (entsel)))
(setq hatcol (vlax-get-property (vlax-Ename->Vla-Object obj) 'color))
(setq pt (getpoint "\nPlease pick inside objects"))
(setvar "HPNAME" "Solid") ;set hatch pattern
(command "-Hatch" pt "" "CO" hatcol "" "")
)
      
(defun *error* (x)
   (if v
   (mapcar 'setvar '(HPNAME CMDECHO) v)
   )
   (if (wcmatch (strcase x) "*BREAK*,*CANCEL*,*EXIT*")
   (princ (strcat "\n** Error: " x " **"))
   )
)
(setq l (entlast)
       v (mapcar 'getvar '(HPNAME CMDECHO))
)
(if (setq ss (ssget "_:L" '((0 . "SPLINE"))))
   (progn (mapcar 'setvar '(HPNAME CMDECHO) '("SOLID" 0))
          (setq l (entlast))
          (vla-startUndomark (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
          ((lambda (i / sn c o)
             (while (setq sn (ssname ss (setq i (1+ i))))
               (command "_.-hatch" "S" sn "" "")
               (if (not (eq l (setq o (entlast))))
               (if (setq c (assoc 62 (entget sn)))
                   (entmod (append (entget o) (list (cons 62 (cdr c)))))
                   (entmod (append (entget o) '((62 . 256))))
               )
               )
               (setq l o)
             )
         )
            -1
          )
          (vla-Endundomark doc)
   )
)
(*error* nil)
)(vl-load-com)

BIGAL 发表于 2022-7-5 23:05:13

把它通过洗衣机与旋转周期和它出来干净。
 
????

Tharwat 发表于 2022-7-5 23:20:22

 
你从哪里得到密码的？为什么你要把作者的名字从例程中删除？

afwjlk2 发表于 2022-7-5 23:40:32

我道歉。我没有恶意。我替换例程中的标题。
我不会把它们当成我自己的。
我正在学习创建LISP。

查看完整版本: 填充图案填充LISP