论坛有没有能提取CAD文件的所有图层信息的lisp？
论坛里边有没有能够提取当前打开CAD文件中的所有图层信息（图层名称、图层颜色、线型、线宽）并输出到当前CAD中的lisp？我再论坛上没找到，可能是我搜索的关键字不对，或者搜索方法不对，哪个大神帮忙指个路。chq168168 发表于 2023-9-15 08:50
大神为什么生成的下边这段程序转成VLX运行不了呢？是不是代码有个#ID跟#DEBUG变量，这俩变量没定义的原因 ...
(DEFUN C:TC1 (/ LST N1 N2 N3 N4 LST1 ERR)
(SETQ LST (LIST
(LIST '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "0")
'(70 . 0)
'(62 . 7)
'(6 . "Continuous")
'(290 . 1)
'(370 . -3)
)
(LIST '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "BEND")
'(70 . 0)
'(62 . 6)
'(6 . "DASHED")
'(290 . 1)
'(370 . -3)
)
(LIST '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "HATCH")
'(70 . 0)
'(62 . 2)
'(6 . "Continuous")
'(290 . 1)
'(370 . -3)
)
(LIST '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "MARK")
'(70 . 0)
'(62 . 3)
'(6 . "Continuous")
'(290 . 1)
'(370 . -3)
)
(LIST '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "LH辅助图层")
'(70 . 0)
'(62 . 6)
'(6 . "Continuous")
'(290 . 1)
'(370 . -3)
)
(LIST '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "LH图层")
'(70 . 0)
'(62 . 1)
'(6 . "Continuous")
'(290 . 1)
'(370 . -3)
)
(LIST '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "DRAW")
'(70 . 0)
'(62 . 7)
'(6 . "Continuous")
'(290 . 1)
'(370 . -3)
)
(LIST '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "細實線")
'(70 . 0)
'(62 . 2)
'(6 . "Continuous")
'(290 . 1)
'(370 . 15)
)
)
)
(setq n1 0
n2 0
N3 0
n4 0
)
(FOREACH LST1 LST
(OR (TBLSEARCH "LTYPE" (CDR (ASSOC 6 LST1)))
(VL-CATCH-ALL-APPLY
(QUOTE vla-Load)
(LIST (vla-get-Linetypes
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(CDR (ASSOC 6 LST1))
(FINDFILE "acad.lin")
)
)
)
(IF (NOT (TBLSEARCH "LAYER" (CDR (ASSOC 2 LST1))))
(PROGN (IF (NOT (ENTMAKE LST1))
(SETQ N1 (+ 1 N1))
(SETQ N2 (+ 1 N2))
)
)
(PROGN
(IF (= X T)
(PROGN (SETQ OLDLST (ENTGET (TBLOBJNAME "layer" (CDR (ASSOC 2 LST1))))
NDXF (LIST 6 62 70 290 370)
)
(IF (= XX nil)
(SETQ N4 (+ 1 N4))
)
(FOREACH I NDXF
(SETQ
OLDLST (SUBST (ASSOC I LST1) (ASSOC I OLDLST) OLDLST)
)
)
(ENTMOD OLDLST)
)
)
)
)
)
(ALERT (STRCAT "\n 未新建图层" (RTOS N1 2 0) "个"))
(ALERT (STRCAT "\n 新建图层" (RTOS N2 2 0) "个"))
(PRINC)
)
这是我用代码生成的lsp文件，不知道你把个#debug从哪来的 本帖最后由 chq168168 于 2023-9-18 14:28 编辑
liuhe 发表于 2023-9-12 12:41
http://bbs.mjtd.com/thread-186295-1-1.html
部分有用
大神为什么生成的下边这段程序转成VLX运行不了呢？是不是代码有个#ID跟#DEBUG变量，这俩变量没定义的原因。
(DEFUN C:TC1( / LST N1 N2 N3 N4 LST1 ERR)
(SETQ LST (LIST
(LIST '(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")'(2 . "0")'(70 . 0)'(62 . 7)'(6 . "Continuous")'(290 . 1)'(370 . -3))
(LIST '(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")'(2 . "00-标注")'(70 . 0)'(62 . 7)'(6 . "Continuous")'(290 . 1)'(370 . -3))
(LIST '(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")'(2 . "00-新增")'(70 . 0)'(62 . 1)'(6 . "Continuous")'(290 . 1)'(370 . -3))
(LIST '(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")'(2 . "01-加工")'(70 . 0)'(62 . 7)'(6 . "Continuous")'(290 . 1)'(370 . -3))
) )(setq n1 0 n2 0 N3 0 n4 0)(FOREACH LST1 LST
(#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"))))))))
(#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))))))))))
)
(#DEBUG (#ID 2 107 14) (ALERT (#DEBUG (#ID 2 107 21) (STRCAT "\n 未新建图层" (#DEBUG (#ID 2 107 38) (RTOS N1 2 0)) "个"))))
(#DEBUG (#ID 2 110 13) (ALERT (#DEBUG (#ID 2 110 20) (STRCAT "\n 新建图层" (#DEBUG (#ID 2 110 37) (RTOS N2 2 0)) "个"))))
(PRINC ) ) 本帖最后由 vitalgg 于 2023-9-12 12:28 编辑
(mapcar '(lambda(x)
(list
(entity:getdxfx 2)
(entity:getdxfx 62)
(entity:getdxfx 6)
(if (> (entity:getdxfx 370) 0)
(* 0.01 (entity:getdxfx 370))
0)))
(mapcar 'layer:ent (layer:list)))
http://bbs.mjtd.com/thread-186295-1-1.html
部分有用 (defun LayerList (/ lst d la)
"LayerList 图层名称、图层颜色、线型、打印、线宽表 (LayerList)"
(while (setq d (tblnext "layer" (null d)))
(setq lst (cons (entget (tblobjname "layer" (setq la (cdr (assoc 2 d))))) lst))
)
(mapcar '(lambda (x) (mapcar 'cdr (vl-remove-if-not '(lambda (a) (member (car a) '(2 62 6 290 370))) x))) (reverse lst))
) http://bbs.mjtd.com/forum.php?mod=viewthread&tid=188260&highlight=%CD%BC%B2%E3 liuhe 发表于 2023-9-12 12:41
http://bbs.mjtd.com/thread-186295-1-1.html
部分有用
非常好，我提取了下图层，然后自动创建了个图层生成lisp。我把lisp文件用作创建图层的子程序。非常实用谢谢大神。 aggdqty 发表于 2023-9-12 13:37
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=188260&highlight=%CD%BC%B2%E3
谢谢，我用楼上liuhe大神的那个代码能满足我的使用 vitalgg 发表于 2023-9-12 12:25
谢谢大神 liuhe 发表于 2023-9-12 12:41
http://bbs.mjtd.com/thread-186295-1-1.html
部分有用
非常好用。想法也挺好的，感谢分享 liuhe 发表于 2023-9-12 12:41
http://bbs.mjtd.com/thread-186295-1-1.html
部分有用
标注样式是否可以提取出来更改成lisp文件？
页:
[1]
2