原户型图按村或社在一个CAD上，现在需要各自按户分开，并只是保留图形部分
1 Private allnum As Long
2 Sub CTall2()
3 Dim filepath As String
4 filepath = ""
5 allnum = 0
6
7 Dim bEnuSub As Boolean
8 bEnuSub = True
9 filepath = InputBox("请输入处理的数据所在文件夹" & vbCr & "（格式 D:\test\test ）:" & vbCr & "***注：CAD初始界面无文档***", "文件夹输入")
10 If filepath = "" Then
11 Exit Sub
12 End If
13
14 Call EnuAllFiles(filepath, bEnuSub)
15 MsgBox ("处理完成，共计户数：" & allnum)
16 End Sub
17
18 Sub EnuAllFiles(ByVal sPath As String, Optional bEnuSub As Boolean = False)
19
20
21 '定义文件系统对象
22 Dim oFso As Object
23 Set oFso = CreateObject("Scripting.FileSystemObject")
24 '定义文件夹对象
25 Dim oFolder As Object
26 Set oFolder = oFso.GetFolder(sPath)
27 '定义文件对象
28 Dim oFile As Object
29 '如果指定的文件夹含有文件
30 If oFolder.Files.Count Then
31 For Each oFile In oFolder.Files
32 With oFile
33 '输出文件所在的盘符
34 Dim sDrive As String
35 sDrive = .Drive
36 '输出文件的类型
37 Dim sType As String
38 sType = .Type
39 '输出含后缀名的文件名称
40 Dim sName As String
41 sName = .Name
42 '输出含文件名的完整路径
43 Dim sFilePath As String
44 sFilePath = .Path
45 '输出文件的上次修改时间
46 Dim dDLM
47 dDLM = .DateLastModified
48 '输出文件的上次访问时间
49 Dim dDLA
50 dDLA = .DateLastAccessed
51 '输出文件的创建时间
52 Dim dDC
53 dDC = .DateCreated
54 '输出文件的属性
55 Dim sATT
56 sATT = .Attributes
57 '如果文件是Word文件
58 If sName Like "*总图XYZ.dwg" Then 'Or sName Like "*宗地草图*.dwg" Or sName Like "*分户图*.dwg" Then
59
60 Call ZDSYT(sFilePath)
61 End If
62 End With
63 Next
64 '如果指定的文件夹不含有文件
65 Else
66 End If
67
68 '如果要遍历子文件夹
69 If bEnuSub = True Then
70 '定义子文件夹集合对象
71 Dim oSubFolders As Object
72 Set oSubFolders = oFolder.SubFolders
73 If oSubFolders.Count > 0 Then
74 For Each oTempFolder In oSubFolders
75 sTempPath = oTempFolder.Path
76 Call EnuAllFiles(sTempPath, True)
77 Next
78 End If
79 Set oSubFolders = Nothing
80 End If
81
82 Set oFile = Nothing
83 Set oFolder = Nothing
84 Set oFso = Nothing
85 End Sub
86
87 Sub ZDSYT(ByVal sfile As String)
88 Dim filename As String, pathname As String, fname As String, zl As String
89 Dim xg1 As Integer, xg2 As Integer
90 Dim pyx As Double, pyy As Double
91
92 filename = sfile
93 Dim AA As String, bb As Integer, cc As Integer
94 Dim ptmin As Variant, ptmax As Variant
95 Dim ssetObj As AcadSelectionSet
96
97 Dim retObjects As Variant
98 Dim ttt() As Object
99
100 xg1 = InStrRev(filename, "\") - 1
101 xg2 = InStrRev(Left(filename, xg1), "\")
102 pathname = Left(filename, xg1 + 1)
103 fname = Right(filename, Len(filename) - xg1 - 1)
104 zl = "AA-"
105 cc = allnum
106
107 Application.Documents.Open filename
108 Set ssetObj = ThisDrawing.SelectionSets.Add("SSET")
109 'ThisDrawing.SaveAs pathname & Replace(fname, ".dwg", ".dxf"), ac2004_dxf
110 'ThisDrawing.Application.Documents(Replace(fname, ".dwg", ".dxf")).Close
111
112 'ThisDrawing.Application.Documents.Open pathname & Replace(fname, ".dwg", ".dxf")
113
114 ThisDrawing.Application.ZoomExtents
115 ThisDrawing.SetVariable "backgroundplot", 0
116 For Each ent In ThisDrawing.Application.Documents(0).ModelSpace
117 If TypeOf ent Is AcadText Or TypeOf ent Is AcadMText Then
118 If ent.TextString Like "*房产座落" Or ent.TextString Like "*房屋座落" Then
119
120 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''缩放
121 pyx = 0: pyy = 0
122 If TypeOf ent Is AcadMText Then
123 pyx = 1.7278: pyy = -0.5257
124 End If
125
126 ptmax = ent.InsertionPoint
127 ReDim Preserve ptmax(0 To 2)
128 ptmax(0) = ptmax(0) + 33.5708 + pyx
129 ptmax(1) = ptmax(1) + 1.6057 + pyy
130 ptmax(2) = 0
131
132 ptmin = ent.InsertionPoint
133 ReDim Preserve ptmin(0 To 2)
134 ptmin(0) = ptmin(0) - 2.0227 + pyx
135 ptmin(1) = ptmin(1) - 44.8 + pyy
136 ptmin(2) = 0
137
138 ThisDrawing.Application.ZoomWindow ptmin, ptmax
139 'time1 = Timer
140 'Do
141 'bb = 0
142 'Loop While Timer - time1 < 2
143 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''编号
144 ' If Len(ent.TextString) > 3 Then
145 ' aa = "-" & Replace(ent.TextString, "编号：", "")
146 ' Else
147 ' ptmax = ent.InsertionPoint
148 ' ReDim Preserve ptmax(0 To 2)
149 ' ptmax(0) = ptmax(0) + 3.7703
150 ' ptmax(1) = ptmax(1) + 0.8509
151 '
152 ' ptmax(2) = 0
153 '
154 ' ptmin = ent.InsertionPoint
155 ' ReDim Preserve ptmin(0 To 2)
156 ' ptmin(0) = ptmin(0) + 2.0901
157 ' ptmin(1) = ptmin(1) - 0.2662
158 ' ptmin(2) = 0
159 '
160 ' ssetObj.Select acSelectionSetWindow, ptmin, ptmax
161 ' For Each ents In ssetObj
162 ' If TypeOf ents Is AcadText Or TypeOf ents Is AcadMText Then
163 ' aa = "-" & ents.TextString
164 ' Exit For
165 ' End If
166 ' Next
167 ' ssetObj.Clear
168 ' End If
169
170
171 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''坐落
172 ptmax = ent.InsertionPoint
173 ReDim Preserve ptmax(0 To 2)
174 ptmax(0) = ptmax(0) + 19.4108 + pyx
175 ptmax(1) = ptmax(1) + 0.9057 + pyy
176 ptmax(2) = 0
177
178 ptmin = ent.InsertionPoint
179 ReDim Preserve ptmin(0 To 2)
180 ptmin(0) = ptmin(0) + 2.0808 + pyx
181 ptmin(1) = ptmin(1) - 0.9443 + pyy
182 ptmin(2) = 0
183
184 ssetObj.Select acSelectionSetWindow, ptmin, ptmax
185 For Each ents In ssetObj
186 If TypeOf ents Is AcadText Or TypeOf ents Is AcadMText Then
187 AA = ents.TextString & "-"
188 zl = ents.TextString & "-"
189 Exit For
190 End If
191 Next
192
193 If AA = "" Then
194 AA = zl
195 End If
196 ssetObj.Clear
197 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''权利人
198 ptmax = ent.InsertionPoint
199 ReDim Preserve ptmax(0 To 2)
200 ptmax(0) = ptmax(0) + 11.1908 + pyx
201 ptmax(1) = ptmax(1) - 1.0843 + pyy
202 ptmax(2) = 0
203
204 ptmin = ent.InsertionPoint
205 ReDim Preserve ptmin(0 To 2)
206 ptmin(0) = ptmin(0) + 2.1008 + pyx
207 ptmin(1) = ptmin(1) - 3.1743 + pyy
208 ptmin(2) = 0
209
210 ssetObj.Select acSelectionSetWindow, ptmin, ptmax
211 For Each ents In ssetObj
212 If TypeOf ents Is AcadText Or TypeOf ents Is AcadMText Then
213 AA = AA & ents.TextString
214 Exit For
215 End If
216 Next
217
218 ssetObj.Clear
219
220
221
222 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''图形
223 ptmax = ent.InsertionPoint
224 ReDim Preserve ptmax(0 To 2)
225 ptmax(0) = ptmax(0) + 33.4508 + pyx
226 ptmax(1) = ptmax(1) - 16.1043 + pyy
227 ptmax(2) = 0
228
229 ptmin = ent.InsertionPoint
230 ReDim Preserve ptmin(0 To 2)
231 ptmin(0) = ptmin(0) - 1.9392 + pyx
232 ptmin(1) = ptmin(1) - 44.6843 + pyy
233 ptmin(2) = 0
234
235 ssetObj.Select acSelectionSetWindow, ptmin, ptmax
236
237 If ssetObj.Count <> 0 Then
238 ReDim ttt(0 To ssetObj.Count - 1)
239 bb = 0
240 For Each ents In ssetObj
241 Set ttt(bb) = ents
242 bb = bb + 1
243 Next
244
245 ThisDrawing.Application.Documents.Add ("anjuHXT.DWT")
246 retObjects = ThisDrawing.Application.Documents(0).CopyObjects(ttt, ThisDrawing.Application.Documents(1).ModelSpace)
247 ssetObj.Clear
248
249 For Each ent1 In ThisDrawing.Application.Documents(1).ModelSpace
250 If TypeOf ent1 Is AcadBlockReference Then
251 If ent1.Name = "BZ_100" Then
252 'ent1.Delete
253 End If
254 Else
255 ent1.color = acWhite
256 End If
257
258 Next ent1
259
260 ThisDrawing.Application.ZoomExtents
261 If Dir("D:\test\" & AA & ".dwg") = Empty Then
262 ThisDrawing.Application.Documents(1).SaveAs "D:\test\" & AA & ".dwg"
263 ElseIf Dir("D:\test\" & AA & "2.dwg") = Empty Then
264 ThisDrawing.Application.Documents(1).SaveAs "D:\test\" & AA & "2.dwg"
265 Else
266 ThisDrawing.Application.Documents(1).SaveAs "D:\test\" & AA & "3.dwg"
267 End If
268
269 ThisDrawing.Application.Documents(1).Close False
270 AA = ""
271 allnum = allnum + 1
272 End If
273 End If
274 End If
275
276 Next ent
277 Application.Documents(0).Save
278 Application.Documents(0).Close False
279 'ThisDrawing.Application.Documents(fname).Close
280
281 If allnum - cc < 20 Then
282 Debug.Print sfile & " 户数小于20户，为：" & allnum - cc
283 End If
284
285 End Sub
标签：Dim,End,按户,Application,存放,ptmin,户型图,ent,ptmax From： https://www.cnblogs.com/jiongya99/p/18103042