总户型图按户分开存放

原户型图按村或社在一个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

 

posted @ 2024-03-29 09:18  生活不该得过且过  阅读(13)  评论(0编辑  收藏  举报