指定块插入到图形的指定位置

874185423

求助编程：我想把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)
程序要求：首先打开第一个文件，把块插入指定的位置，存盘退出，然后在打开第二幅图，依次操作。

gufeng

2. (defun c:tt (/ FILE_LIST FOLD SF SFF RunNow MEMREDLIST REDLIST infofile)
   
3. (vl-load-com)
   
4. ;_读取 文件
   
5. (defun ReadFile2Str (datfile / tmplst x fn)
   
6. (setq fn (open datfile "r"))
   
7. (setq tmplst '())
   
8. (while (setq x (read-line fn))
   
9. (setq x (StrParse x ","))
   
10. (setq tmplst (cons (last x) (cons (car x) tmplst)))
    
11. )
    
12. (close fn)
    
13. (reverse tmplst)
    
14. )
    
15. ;_解析字符串
    
16. (defun StrParse (Str Delimiter / CHAR N RETURN SEARCHSTR STRINGLEN)
    
17. (setq SearchStr Str)
    
18. (setq StringLen (strlen SearchStr))
    
19. (setq return '())
    
20. (while (> StringLen 0)
    
21. (setq n 1)
    
22. (setq char (substr SearchStr 1 1))
    
23. (while (and (/= char Delimiter) (/= char ""))
    
24. (setq n (1+ n))
    
25. (setq char (substr SearchStr n 1))
    
26. )
    
27. (setq return (cons (substr SearchStr 1 (1- n)) return))
    
28. (setq return (cons (substr SearchStr (1+ n)) return))
    
29. (setq StringLen 0)
    
30. )
    
31. (reverse return)
    
32. )
    
33. ;_Thanks caoyin
    
34. ;_http://bbs.mjtd.com/forum.php?mod=viewthread&tid=69986&replyID=&skin=0
    
35. (defun GetFileList (dirName / files lst)
    
36. (defun path-addBackSlash (path)
    
37. (if (not (member (substr path (strlen path)) '("\" "/")))
    
38. (strcat path "\")
    
39. path
    
40. )
    
41. )
    
42. (setq dirName (path-addBackSlash dirName)
    
43. files    (mapcar '(lambda (x) (strcat dirName x))
    
44. (vl-directory-files dirName "*.dwg" 1)
    
45. )
    
46. )
    
47. (mapcar '(lambda (x)
    
48. (setq lst (append lst (GetFileList (strcat dirName x))))
    
49. )
    
50. (vl-remove-if
    
51. '(lambda (x) (member x '("." "..")))
    
52. (vl-directory-files dirName nil -1)
    
53. )
    
54. )
    
55. (append files lst)
    
56. )
    
57. ;; 本代码仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊
    
58. ;; 用途之适应性, 以及商业销售所隐含作出的保证, 在此一概予以否认.
    
59. ;; ========================================================
    
60. ;; 作者：秋枫，参考了灯火的VBA程序
    
61. ;; 用法：(qf_getFolder msg)
    
62. ;; 例子：(qf_getFolder "选择文件夹:")
    
63. ;; 返回值：字符串，文件夹路径，如果点了cancel, 返回nil
    
64. ;; http://www.mjtd.com/Functions/ArticleShow.asp?ArticleID=302
    
65. (defun qf_getFolder (msg / WinShell shFolder path catchit)
    
66. (vl-load-com)
    
67. (setq winshell (vlax-create-object "Shell.Application"))
    
68. (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))
    
69. (setq
    
70. catchit (vl-catch-all-apply
    
71. '(lambda ()
    
72. (setq shFolder (vlax-get-property shFolder 'self))
    
73. (setq path (vlax-get-property shFolder 'path))
    
74. )
    
75. )
    
76. )
    
77. (if  (vl-catch-all-error-p catchit)
    
78. nil
    
79. path
    
80. )
    
81. )
    
82. (setq fold (qf_getFolder "选择文件所在目录:"))
    
83. (if fold
    
84. (progn
    
85. (setq file_list (GetFileList fold))
    
86. (if file_list
    
87. (progn
    
88. (setq infofile (getfiled "选择文件" (strcat fold "\\信息文件") "txt" 0))
    
89. (if (not infofile)
    
90.   (exit)
    
91.   )
    
92. (setq redlist (ReadFile2Str infofile))
    
93. (setq sf (strcat (getvar "TEMPPREFIX") "批处理文件20110922.scr"))
    
94. (setq sff (open sf "w"))
    
95. (setq i 0)
    
96. (mapcar '(lambda (x)
    
97. (if (setq memredlist (member (strcat (vl-filename-base x) ".dwg") redlist))
    
98. (progn
    
99. (setq memredlist (nth 1 memredlist))
    
100. (setq memredlist (substr (setq memredlist (substr memredlist 2)) 1 (1- (strlen memredlist))))
     
101. (princ (strcat "open "" x ""\n" "-insert tk.dwg " memredlist " 1 1 0 qsave close\n") sff)
     
102. (setq i (1+ i))
     
103. )
     
104. )
     
105. )
     
106. file_list
     
107. )
     
108. (close sff)
     
109. (if (> i 0)
     
110. (progn
     
111. (princ (strcat "\n目录下" fold "\n\t共有DWG文件数: " (itoa (length file_list)) ",符合条件的" (itoa i)))
     
112. (initget "Y N")
     
113. (setq RunNow (getkword "\n是否立刻执行[是(Y)/否(N)]:<否>"))
     
114. (if (= RunNow "Y")
     
115. (progn
     
116. (command "._script" sf)
     
117. (princ "\n处理完成")
     
118. )
     
119. (princ "\n放弃立刻执行")
     
120. )
     
121. )
     
122. (princ "\n没有符合条件需要处理的...")
     
123. )
     
124. )
     
125. (princ "\n目录下没有DWG文件")
     
126. )
     
127. )
     
128. (princ "\n请选择目录")
     
129. )
     
130. (princ)
     
131. )

(defun c:tt (/ FILE_LIST FOLD SF SFF RunNow MEMREDLIST REDLIST infofile)<br /> (vl-load-com)<br /> ;_读取 文件<br /> (defun ReadFile2Str (datfile / tmplst x fn)<br /> (setq fn (open datfile "r"))<br /> (setq tmplst '())<br /> (while (setq x (read-line fn))<br /> (setq x (StrParse x ","))<br /> (setq tmplst (cons (last x) (cons (car x) tmplst)))<br /> )<br /> (close fn)<br /> (reverse tmplst)<br /> )<br /> ;_解析字符串<br /> (defun StrParse (Str Delimiter / CHAR N RETURN SEARCHSTR STRINGLEN)<br /> (setq SearchStr Str)<br /> (setq StringLen (strlen SearchStr))<br /> (setq return '())<br /> (while (> StringLen 0)<br /> (setq n 1)<br /> (setq char (substr SearchStr 1 1))<br /> (while (and (/= char Delimiter) (/= char ""))<br /> (setq n (1+ n))<br /> (setq char (substr SearchStr n 1))<br /> )<br /> (setq return (cons (substr SearchStr 1 (1- n)) return))<br /> (setq return (cons (substr SearchStr (1+ n)) return))<br /> (setq StringLen 0)<br /> )<br /> (reverse return)<br /> )<br /> ;_Thanks caoyin<br /> ;_http://bbs.mjtd.com/forum.php?mod=viewthread&tid=69986&replyID=&skin=0<br /> (defun GetFileList (dirName / files lst)<br /> (defun path-addBackSlash (path)<br /> (if (not (member (substr path (strlen path)) '("\" "/")))<br /> (strcat path "\")<br /> path<br /> )<br /> )<br /> (setq dirName (path-addBackSlash dirName)<br /> files    (mapcar '(lambda (x) (strcat dirName x))<br /> (vl-directory-files dirName "*.dwg" 1)<br /> )<br /> )<br /> (mapcar '(lambda (x)<br /> (setq lst (append lst (GetFileList (strcat dirName x))))<br /> )<br /> (vl-remove-if<br /> '(lambda (x) (member x '("." "..")))<br /> (vl-directory-files dirName nil -1)<br /> )<br /> )<br /> (append files lst)<br /> )<br /> ;; 本代码仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊 <br /> ;; 用途之适应性, 以及商业销售所隐含作出的保证, 在此一概予以否认. <br /> ;; ======================================================== <br /> ;; 作者：秋枫，参考了灯火的VBA程序 <br /> ;; 用法：(qf_getFolder msg) <br /> ;; 例子：(qf_getFolder "选择文件夹:") <br /> ;; 返回值：字符串，文件夹路径，如果点了cancel, 返回nil <br /> ;; http://www.mjtd.com/Functions/ArticleShow.asp?ArticleID=302<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 /> (setq fold (qf_getFolder "选择文件所在目录:"))<br /> (if fold<br /> (progn<br /> (setq file_list (GetFileList fold))<br /> (if file_list<br /> (progn<br /> (setq infofile (getfiled "选择文件" (strcat fold "\\信息文件") "txt" 0))<br /> (if (not infofile)<br />   (exit)<br />   )<br /> (setq redlist (ReadFile2Str infofile))<br /> (setq sf (strcat (getvar "TEMPPREFIX") "批处理文件20110922.scr"))<br /> (setq sff (open sf "w"))<br /> (setq i 0)<br /> (mapcar '(lambda (x)<br /> (if (setq memredlist (member (strcat (vl-filename-base x) ".dwg") redlist))<br /> (progn<br /> (setq memredlist (nth 1 memredlist))<br /> (setq memredlist (substr (setq memredlist (substr memredlist 2)) 1 (1- (strlen memredlist))))<br /> (princ (strcat "open "" x ""\n" "-insert tk.dwg " memredlist " 1 1 0 qsave close\n") sff)<br /> (setq i (1+ i))<br /> )<br /> )<br /> )<br /> file_list<br /> )<br /> (close sff)<br /> (if (> i 0)<br /> (progn<br /> (princ (strcat "\n目录下" fold "\n\t共有DWG文件数: " (itoa (length file_list)) ",符合条件的" (itoa i)))<br /> (initget "Y N")<br /> (setq RunNow (getkword "\n是否立刻执行[是(Y)/否(N)]:<否>"))<br /> (if (= RunNow "Y")<br /> (progn<br /> (command "._script" sf)<br /> (princ "\n处理完成")<br /> )<br /> (princ "\n放弃立刻执行")<br /> )<br /> )<br /> (princ "\n没有符合条件需要处理的...")<br /> )<br /> )<br /> (princ "\n目录下没有DWG文件")<br /> )<br /> )<br /> (princ "\n请选择目录")<br /> )<br /> (princ)<br /> )

Andyhon

同行的应是看懂了,
不过我还在猜且无从验证....

874185423

多谢楼主，我得功能全部实现了，只是需要把信息文本插入基点的X,Y互换即可，可能是CAD得X方向是测绘的Y方向的原因吧。

gufeng

需要X Y互换的请替换99行中的

2. (setq memredlist (substr (setq memredlist (substr memredlist 2)) 1 (1- (strlen memredlist))))

(setq memredlist (substr (setq memredlist (substr memredlist 2)) 1 (1- (strlen memredlist))))

为以下代码

2. (setq memredlist (StrParse (substr (setq memredlist (substr memredlist 2)) 1 (1- (strlen memredlist))) ","))
   
3. (setq memredlist (strcat (last memredlist) "," (car memredlist)))

(setq memredlist (StrParse (substr (setq memredlist (substr memredlist 2)) 1 (1- (strlen memredlist))) ","))<br /> (setq memredlist (strcat (last memredlist) "," (car memredlist)))

874185423

多谢gufeng，程序很完美,XY不用互换了

shalei021647

好东西，我收藏了

pengfei2010

太好的资料，必须收藏