可否把CAD所有图纸快速变黑白？？？

rahim96 · 发表于 2013-3-5 09:32:33

比如就是1个文件夹里面有10个CAD图纸，这个图纸除了包含自己画的线线框、还有增加的块，怎么快速把所有CAD图纸变黑白？？？？

比如就是1个文件夹里面有10个CAD图纸，这个图纸除了包含自己画的线线框、还有增加的块，怎么快速把所有CAD图纸变黑白？？？？
以后要是50个图纸，那不是手动1个改好麻烦

gufeng · 发表于 2013-3-5 09:32:34

;|
参考帖子：
http://bbs.mjtd.com/thread-82677-1-1.html
自动打开文件夹下所有文件，并执行图形清理、缩放和保存命令
http://bbs.mjtd.com/thread-30159-1-1.html
修改块内某个实体的所在图层及颜色?(不炸开嵌套块儿的前提下)
把此lsp文件添加到CAD的启动组
|;
(defun c:Test(/ FILE_LIST FOLD SF SFF RunNow GetFileList qf_getFolder)
(vl-load-com)
;_Thanks caoyin
;_http://bbs.mjtd.com/forum.php?mod=viewthread&tid=69986&replyID=&skin=0
(defun GetFileList (dirName / files lst)
(defun path-addBackSlash (path)
(if (not (member (substr path (strlen path)) '("\" "/")))
(strcat path "\")
path
)
)
(setq dirName (path-addBackSlash dirName)
files (mapcar '(lambda (x) (strcat dirName x))
(vl-directory-files dirName "*.dwg" 1)
)
)
(mapcar '(lambda (x)
(setq lst (append lst (GetFileList (strcat dirName x))))
)
(vl-remove-if
'(lambda (x) (member x '("." "..")))
(vl-directory-files dirName nil -1)
)
)
(append files lst)
)
;; 本代码仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊
;; 用途之适应性, 以及商业销售所隐含作出的保证, 在此一概予以否认.
;; ========================================================
;; 作者：秋枫，参考了灯火的VBA程序
;; 用法：(qf_getFolder msg)
;; 例子：(qf_getFolder "选择文件夹:")
;; 返回值：字符串，文件夹路径，如果点了cancel, 返回nil
;; http://www.mjtd.com/Functions/ArticleShow.asp?ArticleID=302
(defun qf_getFolder (msg / WinShell shFolder path catchit)
(vl-load-com)
(setq winshell (vlax-create-object "Shell.Application"))
(setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))
(setq
catchit (vl-catch-all-apply
'(lambda ()
(setq shFolder (vlax-get-property shFolder 'self))
(setq path (vlax-get-property shFolder 'path))
)
)
)
(if (vl-catch-all-error-p catchit)
nil
path
)
)
(setq fold (qf_getFolder "选择文件所在目录:"))
(if fold
(progn
(setq file_list (GetFileList fold))
(if file_list
(progn
(setq sf (strcat (getvar "TEMPPREFIX") "批处理文件20100806.scr"))
(setq sff (open sf "w"))
(mapcar '(lambda (x)
;;; (princ (strcat "open "" x ""\n" "zoom e qsave close\n") sff)
(princ (strcat "open "" x ""\n" "zoom e (changeblockcolorto7) qsave close\n") sff)
)
file_list
)
(close sff)
(princ (strcat "\n目录下" fold "\n\t共有DWG文件数: " (itoa (length file_list))))
(initget "Y N")
(setq RunNow (getkword "\n是否立刻执行[是(Y)/否(N)]:<否>"))
(if (= RunNow "Y")
(progn
(command "._script" sf)
(princ "\n处理完成")
)
(princ "\n放弃立刻执行")
)
)
(princ "\n目录下没有DWG文件")
)
)
(princ "\n请选择目录")
)
(princ)
)
;;_修改颜色
(defun changeblockcolorto7 (/ SS ENAME I)
(setq ss (ssget "x" (list (cons -4 "<not") (cons 0 "INSERT") (cons -4 "not>"))))
(if ss
(progn
(command "change" ss "" "p" "c" 7 "")
)
)
(setq ss (ssget "x" '((0 . "INSERT"))))
(if ss
(progn
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(BLK_COL ename 7)
)
)
)
)
;;BY LUCAS(龙龙仔)
;;把图块顏色改为byblock(供参考)
;;不同的这个块的顏色不一样
;;(不包括属性,标註,引线,公差-------通常我会保留这些给网友自行解决)
;;_(BLK_COL ename color) (BLK_COL (car (entsel)) 7)
(defun BLK_COL (ent clr / EG2 EN2 EN3 NAM NM2 CHBLK)
(defun CHBLK (EN2 NAM CLR)
(while EN2
(setq EG2 (entget EN2)
EN2 (entnext (cdr (assoc -1 EG2)))
)
(if (assoc 62 EG2)
(setq EG2 (subst (cons 62 CLR) (assoc 62 EG2) EG2))
(setq EG2 (append EG2 (list (cons 62 CLR))))
)
(entmod EG2)
(if (= (cdr (assoc 0 EG2)) "INSERT")
(progn
(setq NM2 (cdr (assoc 2 EG2))
EN3 (cdr (assoc -2 (tblsearch "block" NM2)))
)
(CHBLK EN3 NM2 CLR)
)
)
)
(setvar "cmdecho" 1)
(princ)
)
(setvar "cmdecho" 0)
;;; (if (setq ENT (entsel "\nSelect blocks that needs color changed: "))
(if ENT
(progn
;;; (setq CLR (acad_colordlg 7))
(setq NAM (cdr (assoc 2 (entget ENT))))
(setq EN2 (cdr (assoc -2 (tblsearch "block" NAM))))
(CHBLK EN2 NAM 0)
(setq EG2 (entget ENT))
(if (assoc 62 EG2)
(setq EG2 (subst (cons 62 CLR) (assoc 62 EG2) EG2))
(setq EG2 (append EG2 (list (cons 62 CLR))))
)
(entmod EG2)
(entupd ENT)
)
)
(princ)
)

;| 
参考帖子： 
http://bbs.mjtd.com/thread-82677-1-1.html 
自动打开文件夹下所有文件，并执行图形清理、缩放和保存命令 
 
http://bbs.mjtd.com/thread-30159-1-1.html 
修改块内某个实体的所在图层及颜色?(不炸开嵌套块儿的前提下) 
 
把此lsp文件添加到CAD的启动组 
|; 
 
 
(defun c:Test(/ FILE_LIST FOLD SF SFF RunNow GetFileList qf_getFolder) 
(vl-load-com) 
;_Thanks caoyin 
;_http://bbs.mjtd.com/forum.php?mod=viewthread&tid=69986&replyID=&skin=0 
(defun GetFileList (dirName / files lst) 
(defun path-addBackSlash (path) 
(if (not (member (substr path (strlen path)) '("\" "/"))) 
(strcat path "\") 
path 
) 
) 
(setq dirName (path-addBackSlash dirName) 
files (mapcar '(lambda (x) (strcat dirName x)) 
(vl-directory-files dirName "*.dwg" 1) 
) 
) 
(mapcar '(lambda (x) 
(setq lst (append lst (GetFileList (strcat dirName x)))) 
) 
(vl-remove-if 
'(lambda (x) (member x '("." ".."))) 
(vl-directory-files dirName nil -1) 
) 
) 
(append files lst) 
) 
;; 本代码仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊 
;; 用途之适应性, 以及商业销售所隐含作出的保证, 在此一概予以否认. 
;; ======================================================== 
;; 作者：秋枫，参考了灯火的VBA程序 
;; 用法：(qf_getFolder msg) 
;; 例子：(qf_getFolder "选择文件夹:") 
;; 返回值：字符串，文件夹路径，如果点了cancel, 返回nil 
;; http://www.mjtd.com/Functions/ArticleShow.asp?ArticleID=302 
(defun qf_getFolder (msg / WinShell shFolder path catchit) 
(vl-load-com) 
(setq winshell (vlax-create-object "Shell.Application")) 
(setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1)) 
(setq 
catchit (vl-catch-all-apply 
'(lambda () 
(setq shFolder (vlax-get-property shFolder 'self)) 
(setq path (vlax-get-property shFolder 'path)) 
) 
) 
) 
(if (vl-catch-all-error-p catchit) 
nil 
path 
) 
) 
(setq fold (qf_getFolder "选择文件所在目录:")) 
(if fold 
(progn 
(setq file_list (GetFileList fold)) 
(if file_list 
(progn 
(setq sf (strcat (getvar "TEMPPREFIX") "批处理文件20100806.scr")) 
(setq sff (open sf "w")) 
(mapcar '(lambda (x) 
;;;           (princ (strcat "open "" x ""\n" "zoom e qsave close\n") sff) 
(princ (strcat "open "" x ""\n" "zoom e (changeblockcolorto7) qsave close\n") sff) 
) 
file_list 
) 
(close sff) 
(princ (strcat "\n目录下" fold "\n\t共有DWG文件数: " (itoa (length file_list)))) 
(initget "Y N") 
(setq RunNow (getkword "\n是否立刻执行[是(Y)/否(N)]:<否>")) 
(if (= RunNow "Y") 
(progn 
(command "._script" sf) 
(princ "\n处理完成") 
) 
(princ "\n放弃立刻执行") 
) 
) 
(princ "\n目录下没有DWG文件") 
) 
) 
(princ "\n请选择目录") 
) 
(princ) 
) 
 
;;_修改颜色 
(defun changeblockcolorto7 (/ SS ENAME I) 
(setq ss (ssget "x" (list (cons -4 "<not") (cons 0 "INSERT") (cons -4 "not>")))) 
(if ss 
(progn 
(command "change" ss "" "p" "c" 7 "") 
) 
) 
(setq ss (ssget "x" '((0 . "INSERT")))) 
(if ss 
(progn 
(setq i -1) 
(while (setq ename (ssname ss (setq i (1+ i)))) 
(BLK_COL ename 7) 
) 
) 
) 
) 
;;BY LUCAS(龙龙仔) 
;;把图块顏色改为byblock(供参考) 
;;不同的这个块的顏色不一样 
;;(不包括属性,标註,引线,公差-------通常我会保留这些给网友自行解决) 
;;_(BLK_COL ename color) (BLK_COL (car (entsel)) 7) 
(defun BLK_COL (ent clr / EG2 EN2 EN3 NAM NM2 CHBLK) 
(defun CHBLK (EN2 NAM CLR) 
(while EN2 
(setq EG2        (entget EN2) 
EN2        (entnext (cdr (assoc -1 EG2))) 
) 
(if (assoc 62 EG2) 
(setq EG2 (subst (cons 62 CLR) (assoc 62 EG2) EG2)) 
(setq EG2 (append EG2 (list (cons 62 CLR)))) 
) 
(entmod EG2) 
(if (= (cdr (assoc 0 EG2)) "INSERT") 
(progn 
(setq        NM2 (cdr (assoc 2 EG2)) 
EN3 (cdr (assoc -2 (tblsearch "block" NM2))) 
) 
(CHBLK EN3 NM2 CLR) 
) 
) 
) 
(setvar "cmdecho" 1) 
(princ) 
) 
(setvar "cmdecho" 0) 
;;;  (if (setq ENT (entsel "\nSelect blocks that needs color changed: ")) 
(if ENT 
(progn 
;;;      (setq CLR (acad_colordlg 7)) 
(setq NAM (cdr (assoc 2 (entget ENT)))) 
(setq EN2 (cdr (assoc -2 (tblsearch "block" NAM)))) 
(CHBLK EN2 NAM 0) 
(setq EG2 (entget ENT)) 
(if (assoc 62 EG2) 
(setq EG2 (subst (cons 62 CLR) (assoc 62 EG2) EG2)) 
(setq EG2 (append EG2 (list (cons 62 CLR)))) 
) 
(entmod EG2) 
(entupd ENT) 
) 
) 
(princ) 
)

gufeng · 发表于 2013-3-10 00:12:42

图纸变白是什么意思？是所有的图元的颜色包括块内的图元的颜色修改为白色？

rahim96 · 发表于 2013-3-12 10:48:11

gufeng 发表于 2013-3-10 00:12
图纸变白是什么意思？是所有的图元的颜色包括块内的图元的颜色修改为白色？

嗯，是的，能把文件夹里面的CAD图都变黑白

461045462 · 发表于 2013-3-13 15:30:09

gufeng 发表于 2013-3-12 17:16

谢谢楼上的分享！
先收藏，再试试，学习学习。

rahim96 · 发表于 2013-3-13 17:04:41

gufeng 发表于 2013-3-5 09:32

我看了下，还需要多回复帖子才能看到，谢谢，先收藏起来

l18c19 · 发表于 2013-3-13 21:08:27

回帖看下！

xman00 · 发表于 2014-3-28 09:02:24

我来看一下

账号		自动登录	找回密码
密码			注册

可否把CAD所有图纸快速变黑白？？？

最佳答案

相关帖子