王伟，删除图层251内容

情迷法兰西0

2. 
   
3. (defun qf_getFolder (msg / WinShell shFolder path catchit)
   
4.   (vl-load-com)
   
5.   (setq winshell (vlax-create-object "Shell.Application"))
   
6.   (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))
   
7.   (setq
   
8.     catchit (vl-catch-all-apply
   
9.           '(lambda ()
   
10.          (setq shFolder (vlax-get-property shFolder 'self))
    
11.          (setq path (vlax-get-property shFolder 'path))
    
12.            )
    
13.         )
    
14.   )
    
15.   (if (vl-catch-all-error-p catchit)
    
16.     nil
    
17.     path
    
18.   )
    
19. )
    
20. 
    
21. ;|函数功能: 获取目录下(包含子目录)里的某类型文件
    
22. ;使用格式: a为路径名或多个路劲名表，b为扩展名
    
23. ;范    例: (n5-get-files "D:" "lsp"),搜索d盘中所有lsp文件|;
    
24. ;(setq c(n5-get-files b "dat"))
    
25. ;(vl-file-directory-p b)返回T
    
26. ;2016-6-11
    
27. ;095
    
28. (defun n5-get-files(a b / lst mulu wj x )
    
29.   (setq lst '())
    
30. (cond
    
31. ((= (type a)'STR)
    
32.   (if (setq wj (mapcar '(lambda(x)(strcat a "\" x))(vl-directory-files a (strcat"*." b))))
    
33.       (setq lst (cons wj lst)))
    
34.   (if (setq mulu (mapcar '(lambda(x)(strcat a "\" x))(cddr(vl-directory-files a nil -1))))
    
35.     (foreach x mulu(setq lst(cons(n5-get-files x b) lst)))
    
36.       )
    
37. )
    
38. ((= (type a) 'list) (foreach x a (setq lst (cons(n5-get-files x b)lst))))
    
39. )
    
40.     (reverse(apply 'append lst))
    
41. )
    
42. 
    
43. (defun lst-(l1 l2)(if l2(foreach x l2(setq l1(vl-remove x l1)))l1))
    
44. 
    
45. 
    
46. (defun c:tt(/ fp *DBX* COLORLST DBX DOC FILENAME FILENAME1 FILES LAY LAYLST LAYLSTS LAYNAMELST LAYNAMELSTS LAYS MSP NAMELST PATH SUBOBJ)
    
47. (setq *dbx* (strcat "ObjectDBX.AxDbDocument."(substr (getvar "acadver") 1 2)))
    
48. (setq colorlst(list 251 252));要保留的颜色列表
    
49. (setq path(QF_GETFOLDER"选择文件夹"))
    
50. (setq files(N5-GET-FILES path "dwg"))
    
51.   (setq fp(open "c:\\你微笑时很美.txt" "w"))
    
52. (foreach file files
    
53.   (write-line (strcat "当前:"file))
    
54.   (setq filename(VL-FILENAME-MKTEMP nil nil ".dwg"))
    
55.   (vl-file-copy file filename)
    
56.   (setq dbx(vlax-get-or-create-object *dbx*))
    
57.   (vla-open dbx filename)
    
58.   (setq msp(vla-get-ModelSpace dbx))
    
59.   (setq doc(vlax-get msp 'Document))
    
60.   (setq lays(vla-get-layers doc))
    
61.   (setq laylst nil laylsts laylst)
    
62.   (vlax-for lay lays
    
63.    (if (apply'or(mapcar(function(lambda(x)(= x (vla-get-color lay))))colorlst))
    
64.   (setq laylst(cons lay laylst))
    
65.   (if (= "0" (vla-get-name lay))(setq laylst(cons lay laylst))))
    
66.    (setq laylsts(cons lay laylsts)))
    
67.   (setq laynamelsts(mapcar'vla-get-name laylsts));全图层名字
    
68.   (setq namelst(mapcar'vla-get-name laylst));要保留的图层的名字
    
69.   (setq laynamelst(lst- laynamelsts namelst));要删除的图层的名字
    
70.   (vlax-for  subobj msp
    
71.    (if (apply'or(mapcar(function(lambda(x)(= x (vla-get-layer subobj))))laynamelst))
    
72.   (vla-delete subobj)));删除图层上的图形
    
73. ;;;  (mapcar'vla-delete (lst- laylsts laylst));删除图层
    
74.    (foreach x (lst- laylsts laylst)
    
75.      (if(vl-catch-all-error-p(vl-catch-all-apply 'vla-delete (list x)))
    
76.    (write-line (strcat file "  "(vla-get-name x) "图层，删除失败")fp)
    
77.        )
    
78.      )
    
79.   (setq filename1(VL-FILENAME-MKTEMP nil nil ".dwg"))
    
80.   (vlax-invoke dbx 'saveas filename1)
    
81.   (vlax-release-object dbx)
    
82.    
    
83.   (vl-file-delete file)
    
84.   (vl-file-copy filename1 file)
    
85.   (vl-file-delete filename1)
    
86.   )
    
87.   (close fp)
    
88.   (startapp"notepad" "c:\\你微笑时很美.txt")
    
89. (princ)
    
90. )

<br /> (defun qf_getFolder (msg / WinShell shFolder path catchit)<br />   (vl-load-com)<br />   (setq winshell (vlax-create-object "Shell.Application"))<br />   (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))<br />   (setq<br />     catchit (vl-catch-all-apply<br />           '(lambda ()<br />          (setq shFolder (vlax-get-property shFolder 'self))<br />          (setq path (vlax-get-property shFolder 'path))<br />            )<br />         )<br />   )<br />   (if (vl-catch-all-error-p catchit)<br />     nil<br />     path<br />   )<br /> )<br /> <br /> ;|函数功能: 获取目录下(包含子目录)里的某类型文件<br /> ;使用格式: a为路径名或多个路劲名表，b为扩展名<br /> ;范    例: (n5-get-files "D:" "lsp"),搜索d盘中所有lsp文件|;<br /> ;(setq c(n5-get-files b "dat"))<br /> ;(vl-file-directory-p b)返回T<br /> ;2016-6-11<br /> ;095<br /> (defun n5-get-files(a b / lst mulu wj x )<br />   (setq lst '())<br /> (cond<br /> ((= (type a)'STR)<br />   (if (setq wj (mapcar '(lambda(x)(strcat a "\" x))(vl-directory-files a (strcat"*." b))))<br />       (setq lst (cons wj lst)))<br />   (if (setq mulu (mapcar '(lambda(x)(strcat a "\" x))(cddr(vl-directory-files a nil -1))))<br />     (foreach x mulu(setq lst(cons(n5-get-files x b) lst)))<br />       )<br /> )<br /> ((= (type a) 'list) (foreach x a (setq lst (cons(n5-get-files x b)lst))))<br /> )<br />     (reverse(apply 'append lst))<br /> )<br /> <br /> (defun lst-(l1 l2)(if l2(foreach x l2(setq l1(vl-remove x l1)))l1))<br /> <br /> <br /> (defun c:tt(/ fp *DBX* COLORLST DBX DOC FILENAME FILENAME1 FILES LAY LAYLST LAYLSTS LAYNAMELST LAYNAMELSTS LAYS MSP NAMELST PATH SUBOBJ)<br /> (setq *dbx* (strcat "ObjectDBX.AxDbDocument."(substr (getvar "acadver") 1 2)))<br /> (setq colorlst(list 251 252));要保留的颜色列表<br /> (setq path(QF_GETFOLDER"选择文件夹"))<br /> (setq files(N5-GET-FILES path "dwg"))<br />   (setq fp(open "c:\\你微笑时很美.txt" "w"))<br /> (foreach file files<br />   (write-line (strcat "当前:"file))<br />   (setq filename(VL-FILENAME-MKTEMP nil nil ".dwg"))<br />   (vl-file-copy file filename)<br />   (setq dbx(vlax-get-or-create-object *dbx*))<br />   (vla-open dbx filename)<br />   (setq msp(vla-get-ModelSpace dbx))<br />   (setq doc(vlax-get msp 'Document))<br />   (setq lays(vla-get-layers doc))<br />   (setq laylst nil laylsts laylst)<br />   (vlax-for lay lays<br />    (if (apply'or(mapcar(function(lambda(x)(= x (vla-get-color lay))))colorlst))<br />   (setq laylst(cons lay laylst))<br />   (if (= "0" (vla-get-name lay))(setq laylst(cons lay laylst))))<br />    (setq laylsts(cons lay laylsts)))<br />   (setq laynamelsts(mapcar'vla-get-name laylsts));全图层名字<br />   (setq namelst(mapcar'vla-get-name laylst));要保留的图层的名字<br />   (setq laynamelst(lst- laynamelsts namelst));要删除的图层的名字<br />   (vlax-for  subobj msp<br />    (if (apply'or(mapcar(function(lambda(x)(= x (vla-get-layer subobj))))laynamelst))<br />   (vla-delete subobj)));删除图层上的图形<br /> ;;;  (mapcar'vla-delete (lst- laylsts laylst));删除图层<br />    (foreach x (lst- laylsts laylst)<br />      (if(vl-catch-all-error-p(vl-catch-all-apply 'vla-delete (list x)))<br />    (write-line (strcat file "  "(vla-get-name x) "图层，删除失败")fp)<br />        )<br />      )<br />   (setq filename1(VL-FILENAME-MKTEMP nil nil ".dwg"))<br />   (vlax-invoke dbx 'saveas filename1)<br />   (vlax-release-object dbx)<br />    <br />   (vl-file-delete file)<br />   (vl-file-copy filename1 file)<br />   (vl-file-delete filename1)<br />   )<br />   (close fp)<br />   (startapp"notepad" "c:\\你微笑时很美.txt")<br /> (princ)<br /> )