请教如何用LISP获取CAD中的所有填充图案名

xiaocainiao

请教各位大神、如何用lisp获取ANSI、ISO和其他预定义中的所有图案名、
自定义填充知道可以搜索关联路径下的pat文件。
预定义的不知道该如何搜索了

edata

1. (defun parsepatfile  (fn / fd hp ln)
   
2.   (if
   
3.     (and
   
4.       (setq fn (findfile fn))
   
5.       (setq fd (open fn "r"))
   
6.     )
   
7.      (progn
   
8.        (while  (setq ln (read-line fd))
   
9.          (if (wcmatch ln "`**`,*")
   
10.            (setq hp
    
11.                   (cons
    
12.                     (strcase (substr ln 2 (1- (vl-string-position 44 ln))))
    
13.                     hp
    
14.                   )
    
15.            )
    
16.          )
    
17.        )
    
18.        (close fd)
    
19.        (reverse hp)
    
20.      )
    
21.   )
    
22. )

(defun parsepatfile  (fn / fd hp ln)<br />   (if<br />     (and<br />       (setq fn (findfile fn))<br />       (setq fd (open fn "r"))<br />     )<br />      (progn<br />        (while  (setq ln (read-line fd))<br />          (if (wcmatch ln "`**`,*")<br />            (setq hp<br />                   (cons<br />                     (strcase (substr ln 2 (1- (vl-string-position 44 ln))))<br />                     hp<br />                   )<br />            )<br />          )<br />        )<br />        (close fd)<br />        (reverse hp)<br />      )<br />   )<br /> )

1. (parsepatfile (findfile (if (zerop (getvar 'MEASUREMENT)) "acad.pat" "acadiso.pat")))

复制代码

飞雪神光

1. ;;说明:获得图档中包含的填充图案列表
   
2. ;;返回:填充图案列表
   
3. (defun lm-get-hatchlist (/ lst )
   
4.         (defun unique ( lst )
   
5.                 (if lst (cons (car lst) (unique (vl-remove (car lst) (cdr lst)))))
   
6.         )
   
7.         (defun fixdir ( str )
   
8.                 (vl-string-right-trim "\\" (vl-string-translate "/" "\\" str))
   
9.         )
   
10.         (defun parsesupportpaths ( str / pos )
    
11.                 (if (setq pos (vl-string-position 59 str))
    
12.                         (vl-remove "" (cons (substr str 1 pos) (parsesupportpaths (substr str (+ pos 2)))))
    
13.                         (list str)
    
14.                 )
    
15.         )
    
16.         (defun parsepatfile ( fn / fd hp ln )
    
17.                 (if
    
18.                         (and
    
19.                                 (setq fn (findfile fn))
    
20.                                 (setq fd (open fn "r"))
    
21.                         )
    
22.                         (progn
    
23.                                 (while (setq ln (read-line fd))
    
24.                                         (if (wcmatch ln "`**`,*")
    
25.                                                 (setq hp (cons (strcase (substr ln 2 (1- (vl-string-position 44 ln)))) hp))
    
26.                                         )
    
27.                                 )
    
28.                                 (close fd)
    
29.                                 (reverse hp)
    
30.                         )
    
31.                 )
    
32.         )
    
33.        
    
34.         (foreach dir (cons (getvar 'dwgprefix) (parsesupportpaths (getenv "ACAD")))
    
35.                 (foreach pat (vl-directory-files dir "*.pat" 1)
    
36.                         (setq lst (cons (parsepatfile (strcat (fixdir dir) "\\" pat)) lst))
    
37.                 )
    
38.         )
    
39.         (vl-sort (unique (apply 'append lst)) '<)
    
40. )

;;说明:获得图档中包含的填充图案列表<br /> ;;返回:填充图案列表<br /> (defun lm-get-hatchlist (/ lst )<br />         (defun unique ( lst )<br />                 (if lst (cons (car lst) (unique (vl-remove (car lst) (cdr lst)))))<br />         )<br />         (defun fixdir ( str )<br />                 (vl-string-right-trim "\\" (vl-string-translate "/" "\\" str))<br />         )<br />         (defun parsesupportpaths ( str / pos )<br />                 (if (setq pos (vl-string-position 59 str))<br />                         (vl-remove "" (cons (substr str 1 pos) (parsesupportpaths (substr str (+ pos 2)))))<br />                         (list str)<br />                 )<br />         )<br />         (defun parsepatfile ( fn / fd hp ln )<br />                 (if<br />                         (and<br />                                 (setq fn (findfile fn))<br />                                 (setq fd (open fn "r"))<br />                         )<br />                         (progn<br />                                 (while (setq ln (read-line fd))<br />                                         (if (wcmatch ln "`**`,*")<br />                                                 (setq hp (cons (strcase (substr ln 2 (1- (vl-string-position 44 ln)))) hp))<br />                                         )<br />                                 )<br />                                 (close fd)<br />                                 (reverse hp)<br />                         )<br />                 )<br />         )<br />         <br />         (foreach dir (cons (getvar 'dwgprefix) (parsesupportpaths (getenv "ACAD")))<br />                 (foreach pat (vl-directory-files dir "*.pat" 1)<br />                         (setq lst (cons (parsepatfile (strcat (fixdir dir) "\\" pat)) lst))<br />                 )<br />         )<br />         (vl-sort (unique (apply 'append lst)) '<)<br /> )

xiaocainiao

飞雪神光 发表于 2023-6-7 20:37

你这个程序我在论坛里面搜到过、但是我想要的不是这个、我想要的就是截图那个对话框里面的填充图案名、主要是想判断某一个填充是否能用MA去刷

kucha007

xiaocainiao 发表于 2023-6-7 20:58
你这个程序我在论坛里面搜到过、但是我想要的不是这个、我想要的就是截图那个对话框里面的填充图案名、主 ...

试试这样，抓取一下错误？

1. (setq HPNam (cdr (Assoc 2 (Entget (car (nentsel))))))
   
2. (if (not (vl-catch-all-error-p (vl-catch-all-apply 'setvar (list "HPNAME" HPNam))))
   
3.   (princ "\n图案存在")
   
4.   (princ "\n图案不存在")
   
5. )
   
6. (princ)
   

(setq HPNam (cdr (Assoc 2 (Entget (car (nentsel))))))<br /> (if (not (vl-catch-all-error-p (vl-catch-all-apply 'setvar (list "HPNAME" HPNam))))<br />   (princ "\n图案存在")<br />   (princ "\n图案不存在")<br /> )<br /> (princ)<br />

czb203

飞雪神光 发表于 2023-6-7 20:37

神光大侠哪里有您的身影，厉害了

飞雪神光

czb203 发表于 2023-6-7 22:18
神光大侠哪里有您的身影，厉害了

闲着没事就上来逛逛  嫖点代码

cq4920

2. (defun c:ListHatchPatterns (/ ss i)
   
3.   (setq ss (ssget "_X" '((0 . "HATCH"))))
   
4.   (if ss
   
5.     (progn
   
6.       (setq i 0)
   
7.       (while (< i (sslength ss))
   
8.         (setq ent (ssname ss i))
   
9.         (setq patname (cdr (assoc 2 (entget ent))))
   
10.         (princ (strcat "\n" patname))
    
11.         (setq i (1+ i))
    
12.       )
    
13.     )
    
14.     (princ "\nNo hatch patterns found.")
    
15.   )
    
16.   (princ)
    
17. )

(defun c:ListHatchPatterns (/ ss i)<br />   (setq ss (ssget "_X" '((0 . "HATCH"))))<br />   (if ss<br />     (progn<br />       (setq i 0)<br />       (while (< i (sslength ss))<br />         (setq ent (ssname ss i))<br />         (setq patname (cdr (assoc 2 (entget ent))))<br />         (princ (strcat "\n" patname))<br />         (setq i (1+ i))<br />       )<br />     )<br />     (princ "\nNo hatch patterns found.")<br />   )<br />   (princ)<br /> )

飞雪神光

xiaocainiao 发表于 2023-6-7 20:58
你这个程序我在论坛里面搜到过、但是我想要的不是这个、我想要的就是截图那个对话框里面的填充图案名、主 ...

我测试的是对话框里面的都出来了

xiaocainiao

飞雪神光 发表于 2023-6-7 22:57
我测试的是对话框里面的都出来了

对话框里面的会出来、但是一些用不了的填充也会出来、我主要是想要判断图纸中的某一个填充是否可以使用、你发到这个程序是获取文件中的所有填充

xiaocainiao

kucha007 发表于 2023-6-7 21:30
试试这样，抓取一下错误？

我试了一下貌似不太行、不过还是非常感谢