总户型图按户分开存放
原户型图按村或社在一个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
