Function Test() ‘使用双字典
SearchPath = FolderDialog(“请选择文件夹”)
If SearchPath = “” Then
Exit Function
End If
WordName = SplitPath(CStr(SearchPath), 1)
Dim sFile As Object, fso As Object
Set fso = CreateObject(“Scripting.FileSystemObject”)
Set logFile = fso.CreateTextFile(SearchPath & WordName & “日志.txt”, True)
Dim MyWord As Word.Application
Set MyWord = New Word.Application
MyWord.Application.ScreenUpdating = False
MyWord.Application.Visible = True
MyWord.Application.DisplayAlerts = wdAlertsNone
Set myDoc = MyWord.Documents.Add
With MyWord.ActiveDocument.PageSetup
.Orientation = wdOrientLandscape ‘纸张方向横向
End With
Dim CGType() As String ‘动态数组
ReDim Preserve CGType(7)
CGType(0) = “控制点”
CGType(1) = “界址点”
CGType(2) = “界址边长”
CGType(3) = “房角点”
CGType(4) = “房屋边长”
CGType(5) = “房屋面积”
CGType(6) = “巡查”
Dim ExcelApp As Object
If Tasks.Exists(“Microsoft Excel”) = True Then Tasks(“Microsoft Excel”).Close
Set ExcelApp = CreateObject(“Excel.Application”)
Dim wkBook As Object ‘代表excelworkbook（也就是excel工作簿文件 .xls .xlsx)
Dim wkSheet As Object ‘代表excel的工作页
ExcelApp.Application.EnableEvents = False ‘禁止宏等提示的运行
ExcelApp.Application.DisplayAlerts = False
ExcelApp.Application.CutCopyMode = False
Dim DicList, FileList, CunDic, I, FileName(), FilePath()
Dim excelPath As String
Set DicList = CreateObject(“Scripting.Dictionary”)
Set FileList = CreateObject(“Scripting.Dictionary”)
DicList.Add SearchPath, “” ‘初始化目录
‘**************遍历一级目录 获取路径和村名*******************
Do While I < DicList.Count
Key = DicList.keys ‘本次要遍历的目录
NowDic = Dir(Key(I), vbDirectory) ‘开始查找
Do While NowDic <> “”
If (NowDic <> “.”) And (NowDic <> “..”) Then
If (GetAttr(Key(I) & NowDic) And vbDirectory) = vbDirectory Then ‘找到子目录，则添加
If Not DicList.Exists(Key(I) & NowDic & “\”) Then
DicList.Add Key(I) & NowDic & “\”, NowDic
End If
End If
End If
NowDic = Dir() ‘再找
Loop
Exit Do
Loop
‘****************************************************
‘********************获取村所对应的文件夹和子文件夹********************************
Set CunDic = CreateObject(“Scripting.Dictionary”)
k = DicList.keys
v = DicList.Items
For I = 0 To DicList.Count – 1
If Not v(I) = “” Then
CunMin = v(I)
‘加入村名 放在文件字典里
If Not FileList.Exists(CunMin) Then
FileList.Add CunMin, “”
End If
‘FileList.RemoveAll
‘*********************遍历村名下所有的文件夹*****************************
CunDic.RemoveAll
CunDic.Add k(I), “”
J = 0
Do While J < CunDic.Count
Key = CunDic.keys ‘本次要遍历的目录
NowDic = Dir(Key(J), vbDirectory)
Do While NowDic <> “”
If (NowDic <> “.”) And (NowDic <> “..”) Then
If (GetAttr(Key(J) & NowDic) And vbDirectory) = vbDirectory Then ‘找到子目录，则添加
If Not CunDic.Exists(Key(J) & NowDic & “\”) Then
CunDic.Add Key(J) & NowDic & “\”, “”
End If
End If
End If
NowDic = Dir() ‘再找
Loop
J = J + 1
Loop
‘***************************************************
‘******************************在村名下对应的所有目录下搜索XLS文件*******************************
For Each Key In CunDic.keys ‘查找所有目录中的控制点文件
For m = 0 To UBound(CGType) – 1
If m <= UBound(CGType) – 2 Then
NowFile = Dir(Key & “*” & CGType(m) & “*.xls”)
Else
NowFile = Dir(Key & “*” & CGType(m) & “*.docx”)
End If
Do While NowFile <> “”
If Not FileList.Exists(CunMin) Then
FileList.Add CunMin, Key & NowFile ‘FileList.Key=文件名,FileList.Item=目录
Else
If FileList.Item(CunMin) = “” Then
FileList(CunMin) = Key & NowFile
Else
FileList.Item(CunMin) = FileList.Item(CunMin) & “@” & Key & NowFile
End If
End If
NowFile = Dir()
Loop
Next
Next
End If
Next
‘*********************************************************************************************
FileName() = FileList.keys
FilePath() = FileList.Items
For m = 0 To FileList.Count – 1
&nb
