论坛有没有能提取CAD文件的所有图层信息的lisp？

chq168168

论坛里边有没有能够提取当前打开CAD文件中的所有图层信息（图层名称、图层颜色、线型、线宽）并输出到当前CAD中的lisp？我再论坛上没找到，可能是我搜索的关键字不对，或者搜索方法不对，哪个大神帮忙指个路。

liuhe

chq168168 发表于 2023-9-15 08:50
大神为什么生成的下边这段程序转成VLX运行不了呢？是不是代码有个#ID跟#DEBUG变量，这俩变量没定义的原因 ...

2. (DEFUN C:TC1 (/ LST N1 N2 N3 N4 LST1 ERR)
   
3.   (SETQ        LST (LIST
   
4.               (LIST '(0 . "LAYER")
   
5.                     '(100 . "AcDbSymbolTableRecord")
   
6.                     '(100 . "AcDbLayerTableRecord")
   
7.                     '(2 . "0")
   
8.                     '(70 . 0)
   
9.                     '(62 . 7)
   
10.                     '(6 . "Continuous")
    
11.                     '(290 . 1)
    
12.                     '(370 . -3)
    
13.                    )
    
14.               (LIST '(0 . "LAYER")
    
15.                     '(100 . "AcDbSymbolTableRecord")
    
16.                     '(100 . "AcDbLayerTableRecord")
    
17.                     '(2 . "BEND")
    
18.                     '(70 . 0)
    
19.                     '(62 . 6)
    
20.                     '(6 . "DASHED")
    
21.                     '(290 . 1)
    
22.                     '(370 . -3)
    
23.                    )
    
24.               (LIST '(0 . "LAYER")
    
25.                     '(100 . "AcDbSymbolTableRecord")
    
26.                     '(100 . "AcDbLayerTableRecord")
    
27.                     '(2 . "HATCH")
    
28.                     '(70 . 0)
    
29.                     '(62 . 2)
    
30.                     '(6 . "Continuous")
    
31.                     '(290 . 1)
    
32.                     '(370 . -3)
    
33.                    )
    
34.               (LIST '(0 . "LAYER")
    
35.                     '(100 . "AcDbSymbolTableRecord")
    
36.                     '(100 . "AcDbLayerTableRecord")
    
37.                     '(2 . "MARK")
    
38.                     '(70 . 0)
    
39.                     '(62 . 3)
    
40.                     '(6 . "Continuous")
    
41.                     '(290 . 1)
    
42.                     '(370 . -3)
    
43.                    )
    
44.               (LIST '(0 . "LAYER")
    
45.                     '(100 . "AcDbSymbolTableRecord")
    
46.                     '(100 . "AcDbLayerTableRecord")
    
47.                     '(2 . "LH辅助图层")
    
48.                     '(70 . 0)
    
49.                     '(62 . 6)
    
50.                     '(6 . "Continuous")
    
51.                     '(290 . 1)
    
52.                     '(370 . -3)
    
53.                    )
    
54.               (LIST '(0 . "LAYER")
    
55.                     '(100 . "AcDbSymbolTableRecord")
    
56.                     '(100 . "AcDbLayerTableRecord")
    
57.                     '(2 . "LH图层")
    
58.                     '(70 . 0)
    
59.                     '(62 . 1)
    
60.                     '(6 . "Continuous")
    
61.                     '(290 . 1)
    
62.                     '(370 . -3)
    
63.                    )
    
64.               (LIST '(0 . "LAYER")
    
65.                     '(100 . "AcDbSymbolTableRecord")
    
66.                     '(100 . "AcDbLayerTableRecord")
    
67.                     '(2 . "DRAW")
    
68.                     '(70 . 0)
    
69.                     '(62 . 7)
    
70.                     '(6 . "Continuous")
    
71.                     '(290 . 1)
    
72.                     '(370 . -3)
    
73.                    )
    
74.               (LIST '(0 . "LAYER")
    
75.                     '(100 . "AcDbSymbolTableRecord")
    
76.                     '(100 . "AcDbLayerTableRecord")
    
77.                     '(2 . "細實線")
    
78.                     '(70 . 0)
    
79.                     '(62 . 2)
    
80.                     '(6 . "Continuous")
    
81.                     '(290 . 1)
    
82.                     '(370 . 15)
    
83.                    )
    
84.             )
    
85.   )
    
86.   (setq        n1 0
    
87.         n2 0
    
88.         N3 0
    
89.         n4 0
    
90.   )
    
91.   (FOREACH LST1        LST
    
92.     (OR        (TBLSEARCH "LTYPE" (CDR (ASSOC 6 LST1)))
    
93.         (VL-CATCH-ALL-APPLY
    
94.           (QUOTE vla-Load)
    
95.           (LIST        (vla-get-Linetypes
    
96.                   (vla-get-ActiveDocument (vlax-get-acad-object))
    
97.                 )
    
98.                 (CDR (ASSOC 6 LST1))
    
99.                 (FINDFILE "acad.lin")
    
100.           )
     
101.         )
     
102.     )
     
103.     (IF        (NOT (TBLSEARCH "LAYER" (CDR (ASSOC 2 LST1))))
     
104.       (PROGN (IF (NOT (ENTMAKE LST1))
     
105.                (SETQ N1 (+ 1 N1))
     
106.                (SETQ N2 (+ 1 N2))
     
107.              )
     
108.       )
     
109.       (PROGN
     
110.         (IF (= X T)
     
111.           (PROGN (SETQ OLDLST (ENTGET (TBLOBJNAME "layer" (CDR (ASSOC 2 LST1))))
     
112.                        NDXF   (LIST 6 62 70 290 370)
     
113.                  )
     
114.                  (IF (= XX nil)
     
115.                    (SETQ N4 (+ 1 N4))
     
116.                  )
     
117.                  (FOREACH I NDXF
     
118.                    (SETQ
     
119.                      OLDLST (SUBST (ASSOC I LST1) (ASSOC I OLDLST) OLDLST)
     
120.                    )
     
121.                  )
     
122.                  (ENTMOD OLDLST)
     
123.           )
     
124.         )
     
125.       )
     
126.     )
     
127.   )
     
128.   (ALERT (STRCAT "\n 未新建图层" (RTOS N1 2 0) "个"))
     
129.   (ALERT (STRCAT "\n 新建图层" (RTOS N2 2 0) "个"))
     
130.   (PRINC)
     
131. )
     

(DEFUN C:TC1 (/ LST N1 N2 N3 N4 LST1 ERR)<br />   (SETQ        LST (LIST<br />               (LIST '(0 . "LAYER")<br />                     '(100 . "AcDbSymbolTableRecord")<br />                     '(100 . "AcDbLayerTableRecord")<br />                     '(2 . "0")<br />                     '(70 . 0)<br />                     '(62 . 7)<br />                     '(6 . "Continuous")<br />                     '(290 . 1)<br />                     '(370 . -3)<br />                    )<br />               (LIST '(0 . "LAYER")<br />                     '(100 . "AcDbSymbolTableRecord")<br />                     '(100 . "AcDbLayerTableRecord")<br />                     '(2 . "BEND")<br />                     '(70 . 0)<br />                     '(62 . 6)<br />                     '(6 . "DASHED")<br />                     '(290 . 1)<br />                     '(370 . -3)<br />                    )<br />               (LIST '(0 . "LAYER")<br />                     '(100 . "AcDbSymbolTableRecord")<br />                     '(100 . "AcDbLayerTableRecord")<br />                     '(2 . "HATCH")<br />                     '(70 . 0)<br />                     '(62 . 2)<br />                     '(6 . "Continuous")<br />                     '(290 . 1)<br />                     '(370 . -3)<br />                    )<br />               (LIST '(0 . "LAYER")<br />                     '(100 . "AcDbSymbolTableRecord")<br />                     '(100 . "AcDbLayerTableRecord")<br />                     '(2 . "MARK")<br />                     '(70 . 0)<br />                     '(62 . 3)<br />                     '(6 . "Continuous")<br />                     '(290 . 1)<br />                     '(370 . -3)<br />                    )<br />               (LIST '(0 . "LAYER")<br />                     '(100 . "AcDbSymbolTableRecord")<br />                     '(100 . "AcDbLayerTableRecord")<br />                     '(2 . "LH辅助图层")<br />                     '(70 . 0)<br />                     '(62 . 6)<br />                     '(6 . "Continuous")<br />                     '(290 . 1)<br />                     '(370 . -3)<br />                    )<br />               (LIST '(0 . "LAYER")<br />                     '(100 . "AcDbSymbolTableRecord")<br />                     '(100 . "AcDbLayerTableRecord")<br />                     '(2 . "LH图层")<br />                     '(70 . 0)<br />                     '(62 . 1)<br />                     '(6 . "Continuous")<br />                     '(290 . 1)<br />                     '(370 . -3)<br />                    )<br />               (LIST '(0 . "LAYER")<br />                     '(100 . "AcDbSymbolTableRecord")<br />                     '(100 . "AcDbLayerTableRecord")<br />                     '(2 . "DRAW")<br />                     '(70 . 0)<br />                     '(62 . 7)<br />                     '(6 . "Continuous")<br />                     '(290 . 1)<br />                     '(370 . -3)<br />                    )<br />               (LIST '(0 . "LAYER")<br />                     '(100 . "AcDbSymbolTableRecord")<br />                     '(100 . "AcDbLayerTableRecord")<br />                     '(2 . "細實線")<br />                     '(70 . 0)<br />                     '(62 . 2)<br />                     '(6 . "Continuous")<br />                     '(290 . 1)<br />                     '(370 . 15)<br />                    )<br />             )<br />   )<br />   (setq        n1 0<br />         n2 0<br />         N3 0<br />         n4 0<br />   )<br />   (FOREACH LST1        LST<br />     (OR        (TBLSEARCH "LTYPE" (CDR (ASSOC 6 LST1)))<br />         (VL-CATCH-ALL-APPLY<br />           (QUOTE vla-Load)<br />           (LIST        (vla-get-Linetypes<br />                   (vla-get-ActiveDocument (vlax-get-acad-object))<br />                 )<br />                 (CDR (ASSOC 6 LST1))<br />                 (FINDFILE "acad.lin")<br />           )<br />         )<br />     )<br />     (IF        (NOT (TBLSEARCH "LAYER" (CDR (ASSOC 2 LST1))))<br />       (PROGN (IF (NOT (ENTMAKE LST1))<br />                (SETQ N1 (+ 1 N1))<br />                (SETQ N2 (+ 1 N2))<br />              )<br />       )<br />       (PROGN<br />         (IF (= X T)<br />           (PROGN (SETQ OLDLST (ENTGET (TBLOBJNAME "layer" (CDR (ASSOC 2 LST1))))<br />                        NDXF   (LIST 6 62 70 290 370)<br />                  )<br />                  (IF (= XX nil)<br />                    (SETQ N4 (+ 1 N4))<br />                  )<br />                  (FOREACH I NDXF<br />                    (SETQ<br />                      OLDLST (SUBST (ASSOC I LST1) (ASSOC I OLDLST) OLDLST)<br />                    )<br />                  )<br />                  (ENTMOD OLDLST)<br />           )<br />         )<br />       )<br />     )<br />   )<br />   (ALERT (STRCAT "\n 未新建图层" (RTOS N1 2 0) "个"))<br />   (ALERT (STRCAT "\n 新建图层" (RTOS N2 2 0) "个"))<br />   (PRINC)<br /> )<br />

这是我用代码生成的lsp文件，不知道  你把个#debug  从哪来的

chq168168

liuhe 发表于 2023-9-12 12:41
http://bbs.mjtd.com/thread-186295-1-1.html

部分有用

大神为什么生成的下边这段程序转成VLX运行不了呢？是不是代码有个#ID跟#DEBUG变量，这俩变量没定义的原因。

2. (DEFUN C:TC1( / LST N1 N2 N3 N4 LST1 ERR)
   
3. (SETQ LST (LIST   
   
4. (LIST '(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")'(2 . "0")'(70 . 0)'(62 . 7)'(6 . "Continuous")'(290 . 1)'(370 . -3))
   
5. (LIST '(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")'(2 . "00-标注")'(70 . 0)'(62 . 7)'(6 . "Continuous")'(290 . 1)'(370 . -3))
   
6. (LIST '(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")'(2 . "00-新增")'(70 . 0)'(62 . 1)'(6 . "Continuous")'(290 . 1)'(370 . -3))
   
7. (LIST '(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")'(2 . "01-加工")'(70 . 0)'(62 . 7)'(6 . "Continuous")'(290 . 1)'(370 . -3))
   
8. ) )(setq n1 0 n2 0 N3 0 n4 0)(FOREACH LST1 LST
   
9. (#DEBUG (#ID 2 58 30) (OR (#DEBUG (#ID 2 58 34) (TBLSEARCH "LTYPE" (#DEBUG (#ID 2 58 53) (CDR (#DEBUG (#ID 2 58 57) (ASSOC 6 LST1)))))) (#DEBUG (#ID 2 59 5) (VL-CATCH-ALL-APPLY (QUOTE vla-Load) (#DEBUG (#ID 2 61 7) (LIST (#DEBUG (#ID 2 61 13) (vla-get-Linetypes (#DEBUG (#ID 2 62 15) (vla-get-ActiveDocument (#DEBUG (#ID 2 62 39) (vlax-get-acad-object)))))) (#DEBUG (#ID 2 64 13) (CDR (#DEBUG (#ID 2 64 17) (ASSOC 6 LST1)))) (#DEBUG (#ID 2 65 13) (FINDFILE "acad.lin"))))))))
   
10. (#DEBUG (#ID 2 75 8) (IF (#DEBUG (#ID 2 75 12) (NOT (#DEBUG (#ID 2 75 17) (TBLSEARCH "LAYER" (#DEBUG (#ID 2 75 36) (CDR (#DEBUG (#ID 2 75 41) (ASSOC 2 LST1)))))))) (#DEBUG (#ID 2 76 10) (PROGN (#DEBUG (#ID 2 76 17) (IF (#DEBUG (#ID 2 76 20) (NOT (#DEBUG (#ID 2 76 24) (ENTMAKE LST1)))) (#DEBUG (#ID 2 78 12) (SETQ N1 (#DEBUG (#ID 2 78 21) (+ 1 N1)))) (#DEBUG (#ID 2 79 12) (SETQ N2 (#DEBUG (#ID 2 79 21) (+ 1 N2)))))))) (#DEBUG (#ID 2 80 10) (PROGN (#DEBUG (#ID 2 81 12) (IF (#DEBUG (#ID 2 81 16) (= X T)) (#DEBUG (#ID 2 82 14) (PROGN (#DEBUG (#ID 2 83 16) (SETQ OLDLST (#DEBUG (#ID 2 83 29) (ENTGET (#DEBUG (#ID 2 83 37) (TBLOBJNAME "layer" (#DEBUG (#ID 2 83 57) (CDR (#DEBUG (#ID 2 83 62) (ASSOC 2 LST1)))))))) NDXF (#DEBUG (#ID 2 84 29) (LIST 6 62 70 290 370)))) (#DEBUG (#ID 2 88 16) (IF (#DEBUG (#ID 2 88 20) (= XX nil)) (#DEBUG (#ID 2 88 30) (SETQ N4 (#DEBUG (#ID 2 88 39) (+ 1 N4)))))) (#DEBUG (#ID 2 89 16) (FOREACH I NDXF (#DEBUG (#ID 2 90 18) (SETQ OLDLST (#DEBUG (#ID 2 91 25) (SUBST (#DEBUG (#ID 2 91 32) (ASSOC I LST1)) (#DEBUG (#ID 2 91 47) (ASSOC I OLDLST)) OLDLST)))))) (#DEBUG (#ID 2 94 16) (ENTMOD OLDLST))))))))))
    
11. )
    
12. (#DEBUG (#ID 2 107 14) (ALERT (#DEBUG (#ID 2 107 21) (STRCAT "\n 未新建图层" (#DEBUG (#ID 2 107 38) (RTOS N1 2 0)) "个"))))
    
13. (#DEBUG (#ID 2 110 13) (ALERT (#DEBUG (#ID 2 110 20) (STRCAT "\n 新建图层" (#DEBUG (#ID 2 110 37) (RTOS N2 2 0)) "个"))))
    
14. (PRINC ) )

(DEFUN C:TC1( / LST N1 N2 N3 N4 LST1 ERR) <br /> (SETQ LST (LIST   <br /> (LIST '(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")'(2 . "0")'(70 . 0)'(62 . 7)'(6 . "Continuous")'(290 . 1)'(370 . -3))<br /> (LIST '(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")'(2 . "00-标注")'(70 . 0)'(62 . 7)'(6 . "Continuous")'(290 . 1)'(370 . -3))<br /> (LIST '(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")'(2 . "00-新增")'(70 . 0)'(62 . 1)'(6 . "Continuous")'(290 . 1)'(370 . -3))<br /> (LIST '(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")'(2 . "01-加工")'(70 . 0)'(62 . 7)'(6 . "Continuous")'(290 . 1)'(370 . -3))<br /> ) )(setq n1 0 n2 0 N3 0 n4 0)(FOREACH LST1 LST<br /> (#DEBUG (#ID 2 58 30) (OR (#DEBUG (#ID 2 58 34) (TBLSEARCH "LTYPE" (#DEBUG (#ID 2 58 53) (CDR (#DEBUG (#ID 2 58 57) (ASSOC 6 LST1)))))) (#DEBUG (#ID 2 59 5) (VL-CATCH-ALL-APPLY (QUOTE vla-Load) (#DEBUG (#ID 2 61 7) (LIST (#DEBUG (#ID 2 61 13) (vla-get-Linetypes (#DEBUG (#ID 2 62 15) (vla-get-ActiveDocument (#DEBUG (#ID 2 62 39) (vlax-get-acad-object)))))) (#DEBUG (#ID 2 64 13) (CDR (#DEBUG (#ID 2 64 17) (ASSOC 6 LST1)))) (#DEBUG (#ID 2 65 13) (FINDFILE "acad.lin"))))))))<br /> (#DEBUG (#ID 2 75 8) (IF (#DEBUG (#ID 2 75 12) (NOT (#DEBUG (#ID 2 75 17) (TBLSEARCH "LAYER" (#DEBUG (#ID 2 75 36) (CDR (#DEBUG (#ID 2 75 41) (ASSOC 2 LST1)))))))) (#DEBUG (#ID 2 76 10) (PROGN (#DEBUG (#ID 2 76 17) (IF (#DEBUG (#ID 2 76 20) (NOT (#DEBUG (#ID 2 76 24) (ENTMAKE LST1)))) (#DEBUG (#ID 2 78 12) (SETQ N1 (#DEBUG (#ID 2 78 21) (+ 1 N1)))) (#DEBUG (#ID 2 79 12) (SETQ N2 (#DEBUG (#ID 2 79 21) (+ 1 N2)))))))) (#DEBUG (#ID 2 80 10) (PROGN (#DEBUG (#ID 2 81 12) (IF (#DEBUG (#ID 2 81 16) (= X T)) (#DEBUG (#ID 2 82 14) (PROGN (#DEBUG (#ID 2 83 16) (SETQ OLDLST (#DEBUG (#ID 2 83 29) (ENTGET (#DEBUG (#ID 2 83 37) (TBLOBJNAME "layer" (#DEBUG (#ID 2 83 57) (CDR (#DEBUG (#ID 2 83 62) (ASSOC 2 LST1)))))))) NDXF (#DEBUG (#ID 2 84 29) (LIST 6 62 70 290 370)))) (#DEBUG (#ID 2 88 16) (IF (#DEBUG (#ID 2 88 20) (= XX nil)) (#DEBUG (#ID 2 88 30) (SETQ N4 (#DEBUG (#ID 2 88 39) (+ 1 N4)))))) (#DEBUG (#ID 2 89 16) (FOREACH I NDXF (#DEBUG (#ID 2 90 18) (SETQ OLDLST (#DEBUG (#ID 2 91 25) (SUBST (#DEBUG (#ID 2 91 32) (ASSOC I LST1)) (#DEBUG (#ID 2 91 47) (ASSOC I OLDLST)) OLDLST)))))) (#DEBUG (#ID 2 94 16) (ENTMOD OLDLST))))))))))<br /> )<br /> (#DEBUG (#ID 2 107 14) (ALERT (#DEBUG (#ID 2 107 21) (STRCAT "\n 未新建图层" (#DEBUG (#ID 2 107 38) (RTOS N1 2 0)) "个"))))<br /> (#DEBUG (#ID 2 110 13) (ALERT (#DEBUG (#ID 2 110 20) (STRCAT "\n 新建图层" (#DEBUG (#ID 2 110 37) (RTOS N2 2 0)) "个"))))<br /> (PRINC ) )

vitalgg

1. (mapcar '(lambda(x)
   
2.           (list
   
3.            (entity:getdxf  x 2)
   
4.            (entity:getdxf  x 62)
   
5.            (entity:getdxf  x 6)
   
6.            (if (> (entity:getdxf  x 370) 0)
   
7.                (* 0.01 (entity:getdxf  x 370))
   
8.                0)))
   
9.         (mapcar 'layer:ent (layer:list)))
   

(mapcar '(lambda(x)<br />           (list<br />            (entity:getdxf  x 2)<br />            (entity:getdxf  x 62)<br />            (entity:getdxf  x 6)<br />            (if (> (entity:getdxf  x 370) 0)<br />                (* 0.01 (entity:getdxf  x 370))<br />                0)))<br />         (mapcar 'layer:ent (layer:list)))<br />

liuhe

http://bbs.mjtd.com/thread-186295-1-1.html

部分有用

xyp1964

1. (defun LayerList (/ lst d la)
   
2.   "LayerList 图层名称、图层颜色、线型、打印、线宽表 (LayerList)"
   
3.   (while (setq d (tblnext "layer" (null d)))
   
4.     (setq lst (cons (entget (tblobjname "layer" (setq la (cdr (assoc 2 d))))) lst))
   
5.   )
   
6.   (mapcar '(lambda (x) (mapcar 'cdr (vl-remove-if-not '(lambda (a) (member (car a) '(2 62 6 290 370))) x))) (reverse lst))
   
7. )

(defun LayerList (/ lst d la)<br />   "LayerList 图层名称、图层颜色、线型、打印、线宽表 (LayerList)"<br />   (while (setq d (tblnext "layer" (null d)))<br />     (setq lst (cons (entget (tblobjname "layer" (setq la (cdr (assoc 2 d))))) lst))<br />   )<br />   (mapcar '(lambda (x) (mapcar 'cdr (vl-remove-if-not '(lambda (a) (member (car a) '(2 62 6 290 370))) x))) (reverse lst))<br /> )

aggdqty

http://bbs.mjtd.com/forum.php?mo ... hlight=%CD%BC%B2%E3

chq168168

liuhe 发表于 2023-9-12 12:41
http://bbs.mjtd.com/thread-186295-1-1.html

部分有用

非常好，我提取了下图层，然后自动创建了个图层生成lisp。我把lisp文件用作创建图层的子程序。非常实用谢谢大神。

chq168168

aggdqty 发表于 2023-9-12 13:37
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=188260&highlight=%CD%BC%B2%E3

谢谢，我用楼上liuhe大神的那个代码能满足我的使用

chq168168

vitalgg 发表于 2023-9-12 12:25

谢谢大神

cfc

liuhe 发表于 2023-9-12 12:41
http://bbs.mjtd.com/thread-186295-1-1.html

部分有用

非常好用。想法也挺好的，感谢分享

chq168168

liuhe 发表于 2023-9-12 12:41
http://bbs.mjtd.com/thread-186295-1-1.html

部分有用

标注样式是否可以提取出来更改成lisp文件？