指定块插入到图形的指定位置
求助编程：我想把d盘内的tk.dwg插入到文件夹内的每一个文件内，根据文件文件夹信息文本（txt）自动完成。文本信息格式为：文件名，块要插入的基点。67.25-80.50.dwg,(67250,80500)
67.25-80.75.dwg,(67250,80750)
67.25-81.00.dwg,(67250,81000)
67.50-80.50.dwg,(67500,80500)
67.50-80.75.dwg,(67500,80750)
67.50-81.00.dwg,(67500,81000)
67.75-80.50.dwg,(67750,80500)
67.75-80.75.dwg,(67750,80750)
67.75-81.00.dwg,(67750,81000)
程序要求：首先打开第一个文件，把块插入指定的位置，存盘退出，然后在打开第二幅图，依次操作。
(defun c:tt (/ FILE_LIST FOLD SF SFF RunNow MEMREDLIST REDLIST infofile)
(vl-load-com)
;_读取 文件
(defun ReadFile2Str (datfile / tmplst x fn)
(setq fn (open datfile "r"))
(setq tmplst '())
(while (setq x (read-line fn))
(setq x (StrParse x ","))
(setq tmplst (cons (last x) (cons (car x) tmplst)))
)
(close fn)
(reverse tmplst)
)
;_解析字符串
(defun StrParse (Str Delimiter / CHAR N RETURN SEARCHSTR STRINGLEN)
(setq SearchStr Str)
(setq StringLen (strlen SearchStr))
(setq return '())
(while (> StringLen 0)
(setq n 1)
(setq char (substr SearchStr 1 1))
(while (and (/= char Delimiter) (/= char ""))
(setq n (1+ n))
(setq char (substr SearchStr n 1))
)
(setq return (cons (substr SearchStr 1 (1- n)) return))
(setq return (cons (substr SearchStr (1+ n)) return))
(setq StringLen 0)
)
(reverse return)
)
;_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 infofile (getfiled "选择文件" (strcat fold "\\信息文件") "txt" 0))
(if (not infofile)
(exit)
)
(setq redlist (ReadFile2Str infofile))
(setq sf (strcat (getvar "TEMPPREFIX") "批处理文件20110922.scr"))
(setq sff (open sf "w"))
(setq i 0)
(mapcar '(lambda (x)
(if (setq memredlist (member (strcat (vl-filename-base x) ".dwg") redlist))
(progn
(setq memredlist (nth 1 memredlist))
(setq memredlist (substr (setq memredlist (substr memredlist 2)) 1 (1- (strlen memredlist))))
(princ (strcat "open \"" x "\"\n" "-insert tk.dwg " memredlist " 1 1 0 qsave close\n") sff)
(setq i (1+ i))
)
)
)
file_list
)
(close sff)
(if (> i 0)
(progn
(princ (strcat "\n目录下" fold "\n\t共有DWG文件数: " (itoa (length file_list)) ",符合条件的" (itoa i)))
(initget "Y N")
(setq RunNow (getkword "\n是否立刻执行[是(Y)/否(N)]:<否>"))
(if (= RunNow "Y")
(progn
(command "._script" sf)
(princ "\n处理完成")
)
(princ "\n放弃立刻执行")
)
)
(princ "\n没有符合条件需要处理的...")
)
)
(princ "\n目录下没有DWG文件")
)
)
(princ "\n请选择目录")
)
(princ)
)
同行的应是看懂了,
不过我还在猜且无从验证.... 多谢楼主，我得功能全部实现了，只是需要把信息文本插入基点的X,Y互换即可，可能是CAD得X方向是测绘的Y方向的原因吧。 需要X Y互换的请替换99行中的(setq memredlist (substr (setq memredlist (substr memredlist 2)) 1 (1- (strlen memredlist))))为以下代码(setq memredlist (StrParse (substr (setq memredlist (substr memredlist 2)) 1 (1- (strlen memredlist))) ","))
(setq memredlist (strcat (last memredlist) "," (car memredlist))) 多谢gufeng，程序很完美,XY不用互换了 好东西，我收藏了 太好的资料，必须收藏
页:
[1]