获取当前文件图层，生成图层创建lisp文件

liuhe

本代码的主要作用是获取当前文件图层信息，然后形成lisp代码，可以在下一个文件，用lisp创建图层。
相当于图层的导出和导入吧。说实话，cad自带的las文件图层的导出和导入可能更好用，唯一的缺点是无法自动加载线型。
本lisp只是无聊的练习作品吧，怎么用lisp文件自动生成可执行lisp文件。未来也许可以用于修改成提取文件中特殊的图层的代码。本人工作没那么复杂，无心研究了。

如果导入图层文件有重名的，默认是强制更新图层。参数是X=T
有3个问题没有解决，1.不会统计同名图层dxf一样的图层数量。2.不会统计同名图层dxf不一样的图层数量。3.线型加载时，会在命令行输出错误信息提示，不会消除这些信息。
如果有大佬能够指点一下，不胜感激。
源码奉上，不差钱的金主可以花钱直接下载文件。






(defun c:w1 ( / *LAYS* LST LST1 I E1)
  (vl-Load-COM)
  (setq        *LAYS* (vla-get-Layers
                 (vla-get-ActiveDocument (vlax-get-acad-object))
               )
        lst    '()
        lst1   '()
  )
  (setq path "D:\\插件缓存文件\\图层自动生成文件.LSP")
  (setq file (open path "w"))
  (WRITE-LINE "(DEFUN C:TC1( / LST N1 N2 N3 N4 LST1 ERR) " file)
  (WRITE-LINE "(SETQ LST (LIST   " file)
  (vlax-for lay        *LAYS*
;;;    (setq lst (tblsearch "LAYER" (VLA-GET-NAME lay))
;;;          I   0
;;;          E1  NIL
;;;    )
    (setq lst (ENTGET (tblobjname "LAYER" (VLA-GET-NAME lay)))
          I   0
          E1  NIL
    )
  
    (REPEAT (LENGTH LST)
      (COND
        ((= 0 (CAR (NTH I LST)))
         (SETQ E1 (STRCAT "(LIST '" (vl-prin1-to-string (NTH I LST))))
         (SETQ E1
                (STRCAT        E1
                        "'"
                        (vl-prin1-to-string (CONS 100 "AcDbSymbolTableRecord"))
                        "'"
                        (vl-prin1-to-string (CONS 100 "AcDbLayerTableRecord"))
                )
         )
        )
        ((AND (/= -1 (CAR (NTH I LST)))
              (/= 102 (CAR (NTH I LST)))
              (/= 5 (CAR (NTH I LST)))
              (/= 100 (CAR (NTH I LST)))
              (/= 330 (CAR (NTH I LST)))
              (/= 390 (CAR (NTH I LST)))
              (/= 347 (CAR (NTH I LST)))
              (/= 348 (CAR (NTH I LST)))
              (/= 360 (CAR (NTH I LST)))
         )
         (IF (= 'STR (TYPE (CDR (NTH I LST))))(SETQ E1 (STRCAT E1 "'" (vl-prin1-to-string (NTH I LST))))
         (SETQ E1 (STRCAT E1 "'" (vl-princ-to-string (NTH I LST)))))
        )
      )
      (SETQ I (+ 1 I))
    )
    (SETQ E1 (STRCAT E1 ")" ))
    (WRITE-LINE (vl-princ-to-string E1) file)
  )
(WRITE-LINE ") )(setq n1 0 n2 0 N3 0 n4 0)(FOREACH LST1 LST" file)
(WRITE-LINE
   (vl-prin1-to-string(quote (or (TBLSEARCH "LTYPE" (CDR(ASSOC 6 LST1)))
    (vl-catch-all-apply
      'vla-load
      (list (vla-get-Linetypes
              (vla-get-ActiveDocument (vlax-get-acad-object))
              )
            (CDR(ASSOC 6 LST1))
            (findfile "acad.lin")
            )
      )
    )))
        file
)

(WRITE-LINE
   (vl-prin1-to-string
     (quote
       (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)
               )
;;;                (foreach        i ndxf
;;;                 (SETQ XX (LISTP (MEMBER (assoc i lst1) oldlst))))
               (if (= xx nil)(setq n4 (+ 1 n4)))
               (foreach        i ndxf
                 (setq oldlst
                        (subst (assoc i lst1) (assoc i oldlst) oldlst)
                 )
               )
               (entmod oldlst)
;;;               (if(not(entmod oldLST)) (setq n3 (+ 1 n3))(setq n4 (+ 1 n4)))
             )
           )
         )
       )
     )
   )
   file
)
  (WRITE-LINE " )" file)
  (WRITE-LINE
   (vl-prin1-to-string
     (quote  (alerT (STRCAT"\n 未新建图层"(rtos n1 2 0)"个"))))file)
  (WRITE-LINE
   (vl-prin1-to-string
     (quote (alerT (STRCAT "\n 新建图层"(rtos n2 2 0)"个"))))file)
;;;  (WRITE-LINE
;;;   (vl-prin1-to-string
;;;     (quote  (alerT (STRCAT"\n 未成功更新图层"(rtos n3 2 0)"个"))))file)
;;;     (WRITE-LINE
;;;   (vl-prin1-to-string
;;;     (quote  (alerT (STRCAT"\n 强制更新图层"(rtos n4 2 0)"个"))))file)
  (WRITE-LINE "(PRINC ) )" file)
   (close file)
)
                          

hkhbs

貌似不完善 获取当前文件层 然后 另外文件可以创建  虽然内插或者复制也可以创建层

llsheng_73

个人感觉通过代码获取模板文件的图层信息写成LSP文件意义不大，因为图层本身并不复杂，关键的DXF码就那么几个，当然作为练手还是可以的。
生成的代码中，运行时按模板生成当前图形没有的图层和修改已有图层为模板图层是有必要的，至于1和2的统计其实很简单，如果没有强迫症的话，可以简单粗暴些，非此即彼即可，对于lsp中提供的图层名，如果当然图层没有，那么就是新建的，如果有，那就修改为模板的图层，分别用一个表来记录它们就行了
3这个问题，加载线型，可能有的图形文件中的线型，换个电脑或者少装一个第三方插件，就会缺少某个线型，根据个人经验，我是把需要的线型，同样获取它的DXF数据，在新图形文件中，直接生成它，不加载线型文件，因为我无法保证换个地方那个线型文件它还存在。。。

1. (vl-every'(lambda(x / e)(setq e(tblobjname"ltype"(car x)))
   
2.                   (if e(entmod(cons(cons -1 e)(cdr x)))(entmakex(cdr x))))
   
3.                '(("X5"(0 . "LTYPE")(100 . "AcDbSymbolTableRecord")(100 . "AcDbLinetypeTableRecord")(2 . "X5")(70 . 0)(3 . "")(72 . 65)(73 . 2)(40 . 3.0)(49 . 2.0)(74 . 0)(49 . -1.0)(74 . 0))
   
4.                  ("X32"(0 . "LTYPE")(100 . "AcDbSymbolTableRecord")(100 . "AcDbLinetypeTableRecord")(2 . "X32")(70 . 0)(3 . "")(72 . 65)(73 . 2)(40 . 1.5)(49 . 1.0)(74 . 0)(49 . -0.5)(74 . 0))))

(vl-every'(lambda(x / e)(setq e(tblobjname"ltype"(car x)))<br />                   (if e(entmod(cons(cons -1 e)(cdr x)))(entmakex(cdr x))))<br />                '(("X5"(0 . "LTYPE")(100 . "AcDbSymbolTableRecord")(100 . "AcDbLinetypeTableRecord")(2 . "X5")(70 . 0)(3 . "")(72 . 65)(73 . 2)(40 . 3.0)(49 . 2.0)(74 . 0)(49 . -1.0)(74 . 0))<br />                  ("X32"(0 . "LTYPE")(100 . "AcDbSymbolTableRecord")(100 . "AcDbLinetypeTableRecord")(2 . "X32")(70 . 0)(3 . "")(72 . 65)(73 . 2)(40 . 1.5)(49 . 1.0)(74 . 0)(49 . -0.5)(74 . 0))))

这两个线型是我在后边会用到的，至于从哪个线型文件能加载到它我不管，我直接把它们的DXF数据搞出来，直接生成这两个线型完事，如果存在同名线型，那么就修改它的DXF数据使之成为我需要的线型，其实道理和图层信息的重建完全是一回事

paulpipi

挺好的，也可以用写图层的程序也可以，但你这个去别的公司用就比较好