excel2007/2010 遍历文件功能

[vb]代码库

FileSearch 物件已從 2007 Microsoft Office 程式中去除(這麼好用的功能也拿掉了，真是給他..00XX)，詳細的說明請參考
KB935402說明，在說明中微軟有提示可以使用Dir 函式或 FileSystemObject
類別來搜索檔案，今天就依這個提示來做一個類似Application.FileSearch的功能，可以設定是否搜尋子資料夾，詳細說明請參考程式碼….



Dim strArr() As String, rCount As Integer
Sub App_FileSearch()
'設定要搜尋檔案的關鍵字
'如果要列出所有檔案請設定為String = ""
Const keyword As String = "*.xls" '搜尋xls檔案
    'App_SearchSubFolder(keyword, True) '搜尋包含子資料夾
    'App_SearchSubFolder(keyword, False) '搜尋不包含子資料夾
    Call App_SearchSubFolder(keyword, True)
    If UBound(strArr) > 0 Then
        '以超連結的方式列出檔案
        For i = 0 To UBound(strArr)
            If strArr(i) <> "" Then
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 3, "A"), _
                        Address:=strArr(i), TextToDisplay:=strArr(i)
            End If
        Next i
    Else
        MsgBox "未發現檔案"
    End If
End Sub
Function App_SearchSubFolder(keyword As String, rSearchSubFolders As Boolean)
Dim fd As Object
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    '開啟Excel內建的資料夾瀏覽方塊
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = -1 Then
        rLookIn = fd.SelectedItems(1)
    Else
        MsgBox "未選取資料夾": Exit Function
    End If
    rFilename = Dir$(rLookIn & "\" & keyword)
    rCount = 0
    '建立動態陣列
    ReDim Preserve strArr(rCount)
    '第一階資料夾
    Do While rFilename <> vbNullString
        strArr(rCount) = rLookIn & "\" & rFilename
        rCount = rCount + 1
        ReDim Preserve strArr(rCount)
        rFilename = Dir$()
    Loop
    If rSearchSubFolders Then    '判斷是否搜尋子資料夾
        '搜尋第二階以後的子資料夾
        Call App_NextSubFolder(fso.GetFolder(rLookIn), keyword)
    End If
    Set fd = Nothing
    Set fso = Nothing
End Function

Private Sub App_NextSubFolder(ByRef Folder As Object, _
        ByRef keyword As String)
Dim SubFolder As Object
    For Each SubFolder In Folder.SubFolders
        rFilename = Dir$(SubFolder.Path & "\" & keyword)
        Do While rFilename <> vbNullString
            strArr(rCount) = SubFolder.Path & "\" & rFilename
            rCount = rCount + 1
            ReDim Preserve strArr(rCount)
            rFilename = Dir$()
        Loop
        Call App_NextSubFolder(SubFolder, keyword)
    Next
End Sub