EXCEL2007下Application.FileSearch使用

FREEOUT

怎样在2007下使用Application.FileSearch，可以在已经打开的EXCEL下运行VB，然后打开指定目录，指定名称的EXCEL文件？谢谢。求各位高手解决

FREEOUT

谢谢您的热心回复。认真学习中。

三戒

请参考
http://club.excelhome.net/viewthread.php?tid=276192

ssfar

看到你的宏代码, 因为我在做资料整理，
能不能提取文件夹中的所有资料，而不只是xls文件？

chijanzen

你好:
我也是用了2007才發現不能用
這是我的替代方法  
Application.FileSearch 在Excel2007的替代方法

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


[ 本帖最后由 chijanzen 于 2008-11-26 18:22 编辑 ]

james.yang

从中收益很多,不知道你有没有关于excel 2007 application这一块的资料,如果有的话,能否发一份给我呢?我的邮箱地址:yangqinghua2002@hotmail.com

yyj198368

谢谢二楼的详细回复,这段正在为filesearch不能用而不解,不过我用的是2003,莫非跟那个系统补丁有关???  看了一下你的代码,非常有用FSO DIR  谢谢

jacksonzeng

收藏一下,我最近也要用到该方法了

shanchuan

请大侠帮助修改代替FileSearch的程序（未解决）
如何在EXCEL2007中用FSO代替FileSearch（循环遍历）？
原代码：
With Application.FileSearch
        .LookIn = ThisWorkbook.Path
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
                If .FoundFiles(i) <> ThisWorkbook.FullName Then
                    Workbooks.Open .FoundFiles(i)
请写出利用FileSystemObject对象替代的代码：

zhangyong

感谢三戒高手提供的好东西，我在国外的好多Excel论坛上都有人抱怨这个问题，我试了很多他们提供的代码，这个是比较经典的一个。转过来大家一起享受！

Excel
VBA
Application.FileSearch
2003
2007

'!!!! Replacement solution including searching in subdirectories !!!


//------------------------------------------------------------------------------------------------

Sub FileSearchByHavrda_Example_of_procedure_calling()
'
' Example of FileSearchByHavrda procedure calling as replacement of missing FileSearch function in the newest MS Office VBA
' 01.06.2009, Author: P. Havrda, Czech Republic
'

Dim FileNameWithPath As Variant
Dim ListOfFilenamesWithParh As New Collection    ' create a collection of filenames

' Filling a collection of filenames (search Excel files including subdirectories)
Call FileSearchByHavrda(ListOfFilenamesWithParh, "C:\Temp", "*.xls", True)

' Print list to immediate debug window and as a message window
For Each FileNameWithPath In ListOfFilenamesWithParh    ' cycle for list(collection) processing
        Debug.Print FileNameWithPath & Chr(13)
        MsgBox FileNameWithPath & Chr(13)
Next FileNameWithPath

' Print to immediate debug window and message if no file was found
If ListOfFilenamesWithParh.Count = 0 Then
    Debug.Print "No file was found !"
    MsgBox "No file was found !"
End If

End Sub

//------------------------------------------------------------------------------------------------

Private Sub FileSearchByHavrda(pFoundFiles As Collection, pPath As String, pMask As String, pIncludeSubdirectories As Boolean)
'
' Search files in Path and create FoundFiles list(collection) of file names(path included) accordant with Mask (search in subdirectories if enabled)
' 01.06.2009, Author: P. Havrda, Czech Republic
'

Dim DirFile As String
Dim CollectionItem As Variant
Dim SubDirCollection As New Collection

' Add backslash at the end of path if not present
pPath = Trim(pPath)
If Right(pPath, 1) <> "\" Then pPath = pPath & "\"

' Searching files accordant with mask
DirFile = Dir(pPath & pMask)
Do While DirFile <> ""
pFoundFiles.Add pPath & DirFile  'add file name to list(collection)
DirFile = Dir ' next file
Loop

' Procedure exiting if searching in subdirectories isn't enabled
If Not pIncludeSubdirectories Then Exit Sub

' Searching for subdirectories in path
DirFile = Dir(pPath & "*", vbDirectory)
Do While DirFile <> ""
    ' Add subdirectory to local list(collection) of subdirectories in path
    If DirFile <> "." And DirFile <> ".." Then If ((GetAttr(pPath & DirFile) And vbDirectory) = 16) Then SubDirCollection.Add pPath & DirFile
    DirFile = Dir 'next file
Loop

' Subdirectories list(collection) processing
For Each CollectionItem In SubDirCollection
     Call FileSearchByHavrda(pFoundFiles, CStr(CollectionItem), pMask, pIncludeSubdirectories) ' Recursive procedure call
Next

End Sub

//------------------------------------------------------------------------------------------------