vba查找文件的问题

Question

我需要做一个查找指定目录下的相关文件功能指定目录（folder）由人为输入
相关文件名（fileName）也由人为输入，特别注意，fileName需要可以包含通配符如：*,?以下是我自己实现的一段代码    Dim fs As FileSearch
    Set fs = Application.FileSearch
    With fs
        .LookIn = folder
        .Filename = fileName
        .SearchSubFolders = True
        If .Execute(msoSortByFileName, msoSortOrderAscending) > 0 Then
            For i = 1 To .FoundFiles.Count
                Cells(i, 1) = .FoundFiles(i)
            Next
        End If
    End With不过这段代码有点小问题，①当fileName="a*.*"的时候能正常查出文件名第一个字母为a的所有文件
②但是当fileName="a*.java"的时候就不能正常查出文件名第一个字母为a的所有文件了，这时查出的是所有文件名包含a的文件，不止单单是第一个字母为a能查出，第二、三个字母为a都会被查出来，如同是在查找"*a*.java"一样
③我继续试验下去，发现当查找fileName="a*.ja"时，和②时的结果一样，试验了多次发现其实实际的查找效果如同是在这个字符串的头尾都默认加了个"*"通配符在查找一样，查"a*.java"其实就是在查"*a*.java*"
④我查找"a*.java;a*.txt"，本意是查找第一个字母为a的java和txt文件，可是也和③一样，实际查找的结果是含有a的java文件和第一个字母为a的txt文件，即"*a*.java;a*.txt*"请高手帮忙解决这个问题！！！另外我自己在网上查了下，发现可能是windows xp的问题
如果这个问题没法解决的话，那希望哪位高手能帮我想一种另外的方法来查找文件，需求是目标文件夹和文件名由人来输入，文件名可包含通配符，例：a*.java;a*.txt（查找文件名第一个字母为a的java和txt这2种文件）

Answer 1

 
 Dim fs As FileSearch 
    Set fs = Application.FileSearch 
    With fs 
        .LookIn = folder 
        .Filename = fileName '(*.txt or *.java)
        .SearchSubFolders = True 
        If .Execute(msoSortByFileName, msoSortOrderAscending) > 0 Then 
            For i = 1 To .FoundFiles.Count 
                if left(.FoundFiles(i),1)="a"  '增加判断第一个字符是否是 "a"
                  Cells(i, 1) = .FoundFiles(i) 
                end if
            Next 
        End If 
    End With
 

Answer 2

Option ExplicitPrivate Sub Command1_Click()
  '示例
  Dim Arr() As String
  Arr = FindFile("C:\Windows", "b*.txt")
  Dim i As Long
  For i = 1 To UBound(Arr)
    MsgBox Arr(i)  '读出每一个文件名称
  Next
End Sub
Private Function FindFile(ByVal Folder As String, ByVal fFileName As String) As String()
   Dim FileName() As String
   Dim mFileName As String
   Dim Count As Long
   
   ReDim FileName(0) As String
   
   mFileName = Dir(Folder & "\" & fFileName)
   While Len(mFileName) <> 0
      Count = Count + 1
      ReDim Preserve FileName(Count) As String
      FileName(Count) = mFileName
      mFileName = Dir
   Wend   FindFile = FileName
End Function

Answer 3

Option ExplicitPrivate Const LB_ADDSTRING = &H180
Private Const WM_SETREDRAW = &HB
Private Const WM_VSCROLL = &H115
Private Const SB_BOTTOM = 7
Private Const INVALID_HANDLE_VALUE = -1
Private Const vbKeyDot = 46Private Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End TypePrivate Type WIN32_FIND_DATA
        dwFileAttributes As Long
        ftCreationTime As FILETIME
        ftLastAccessTime As FILETIME
        ftLastWriteTime As FILETIME
        nFileSizeHigh As Long
        nFileSizeLow As Long
        dwReserved0 As Long
        dwReserved1 As Long
        cFileName As String * 260
        cAlternate As String * 14
End Type
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Const DRIVE_CDROM = 5
Private Const DRIVE_FIXED = 3
Private Const DRIVE_RAMDISK = 6
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_REMOVABLE = 2
Dim FindNumber As Integer
Dim Programme1, Programme2, MyPath As String
Dim RunTime As IntegerDim files1$, files2%
Dim TotalDirs%, TotalFiles%, Running%
Dim www As WIN32_FIND_DATA, fitem&, ffile&
Dim driveName As String
Public cSearchResult As String
Private Sub SearchDirs(curpath$)
        Dim dirs%, dirbuf$(), i%
        'Label1.Caption = ""
        'Label1.Caption = "正在查找：" & curpath$
        DoEvents
        If Not Running% Then
           Exit Sub
        End If
        fitem& = FindFirstFile(curpath$ & "*.*", www)
        If fitem& <> INVALID_HANDLE_VALUE Then
           Do
             If (www.dwFileAttributes And vbDirectory) Then
                If Asc(www.cFileName) <> vbKeyDot Then
                   TotalDirs% = TotalDirs% + 1
                   If (dirs% Mod 10) = 0 Then
                      ReDim Preserve dirbuf$(dirs% + 10)
                   End If
                   dirs% = dirs% + 1
                   dirbuf$(dirs%) = Left$(www.cFileName, InStr(www.cFileName, vbNullChar) - 1)
                End If
             ElseIf Not files2% Then
                TotalFiles% = TotalFiles% + 1
             End If
           Loop While FindNextFile(fitem&, www)
           Call FindClose(fitem&)
        End If
        If files2% Then
           SendMessage List1.hwnd, WM_SETREDRAW, 0, 0
           Call SearchFileSpec(curpath$)
           SendMessage List1.hwnd, WM_VSCROLL, SB_BOTTOM, 0
           SendMessage List1.hwnd, WM_SETREDRAW, 1, 0
        End If
        For i% = 1 To dirs%
            Text1.Text = curpath$ & dirbuf$(i%) & "\"
            SearchDirs curpath$ & dirbuf$(i%) & "\"
        Next i%
End SubPrivate Sub SearchFileSpec(curpath$)
        ffile& = FindFirstFile(curpath$ & files1$, www)
        If ffile& <> INVALID_HANDLE_VALUE Then
           Do
              DoEvents
              If Not Running% Then Exit Sub
              SendMessage List1.hwnd, LB_ADDSTRING, 0, ByVal curpath$ & Left$(www.cFileName, InStr(www.cFileName, vbNullChar) - 1)
           Loop While FindNextFile(ffile&, www)
           Call FindClose(ffile&)
        End If
End SubPrivate Sub Combo1_Change()
        files1$ = Combo1.Text
End SubPrivate Sub Combo1_Click()
        files1$ = Combo1.Text
End SubPrivate Sub Command1_Click()
        Dim drvbbitmask&, maxpwr%, pwr%
        Dim SearchDR As String
        Dim Index As Integer
        Dim information As Long
        'If Running% Then
        '   Command1.Caption = "查找"
        '   Running% = False
        '   Exit Sub
        'End If
        On Error Resume Next
        Command1.Caption = "停止"
        For Index = 0 To Drive1.ListCount - 1
            If Len(files1$) = 0 Then Exit Sub
            Running% = True
            files2% = True
            'List1.Clear
            information = GetDriveType(Left(Drive1.List(Index), 2))
            'MsgBox ("DriveName=" & Left(Drive1.List(Index), 2) & "   DriveType=" & information)
            If information = DRIVE_CDROM Then GoTo cjl
            Call SearchDirs(Left(Drive1.List(Index), 2) & "\")
            Running% = False
            files2% = False
            If List1.ListCount <> 0 Then
               cSearchResult = Trim(List1.List(0))
               Exit For
            End If
cjl:    Next Index
        If FindNumber <= 1 Then
           Label1.Visible = True
           If List1.ListCount <> 0 Then
              Programme1 = Trim(List1.List(0)) & " /n,/e,"
              Label1.Caption = "资源管理器安装在：" & Trim(List1.List(0))
           Else
              Label1.Caption = "没有找到资源管理器！"
           End If
           Call Form_Load
           'Exit Sub
        Else
           Label4.Visible = True
           If List1.ListCount <> 0 Then
              Programme2 = Trim(List1.List(0))
              Label4.Caption = "画图程序安装在：" & Trim(List1.List(0))
           Else
              Label4.Caption = "没有找到画图程序！"
           End If
        End If
        'SetupForm.Show
        Command2.Enabled = True
         
        'Command1.Caption = "查找"
        'Call Command2_Click
End SubPrivate Sub Command2_Click()
        Unload Me
        End
End SubPrivate Sub Drive1_Change()
        driveName = Drive1.Drive
End SubPrivate Sub Form_Load()
        SearchFiles.Height = 1800
        SearchFiles.Width = 6375
        Shape1.Left = 0
        Shape1.Top = 0
        Shape1.Height = SearchFiles.Height
        Shape1.Width = SearchFiles.Width
        Timer1.Enabled = True
        Timer1.Interval = 1000
        RunTime = 0
        
        'Caption = "正在查找资源管理器和画图程序"
        'Label1.Caption = ""
        Label2.Caption = "正在准备，请稍候···"
        'Label3.Caption = "选择要查找的文件类型"
        'Command1.Caption = "开始查找"
        'Command2.Caption = "退出"
        MyPath = IIf(Right(App.Path, 1) = "\", App.Path, App.Path & "\")
        FindNumber = FindNumber + 1
        
        Command2.Enabled = False
        
        If FindNumber <= 1 Then
           Combo1.AddItem "E*.EXE"
           Combo1.Text = "E*.EXE"
        Else
           Combo1.AddItem "ms*.exe"
           Combo1.Text = "ms*.exe"
        End If
        driveName = "c:"
        List1.Clear
        SearchFiles.Show
        'SetupForm.Hide
        Call Command1_Click
        
End SubPrivate Sub Timer1_Timer()
        'Dim i As String
        RunTime = RunTime + 1
        'i = IIf(Len(Trim(Str(RunTime))) < 2, Space(1), Space(0))
        Label5.Caption = "运行时间：" & Trim(Str(RunTime)) & " 秒"
End Sub

Answer 4

支持进度条的文件搜索
方法二： 
用FSO'===========================================================
' 类名        ：  clsFileSearch
' 版本号      ：  1.0
' 说明        ：  根据用户选择的目录，将改目录下，包括子目录中
'                 所有的文件都找出来，并用 Dictionary 集合返回。
'                 文件的选择由调用本类的程序灵活判断。
'                 处理的进度用事件抛出给调用本类的程序。
' 引用        ：  Microsoft Office 12.0 Object Library
'                 Microsoft Scripting Runtime
' 输入参数    ：  --
' 输出值      ：  --
' 返回值      ：  --
' 调用演示    ：  --
' 最后修改日期：  2008-10-4 17:36:00
' 示例地址    ：  http://access911.net/?kbid;78FAB01E17DC
' 作者        ：  cg1
' 网站        ：  http://access911.net
' 电子邮件    ：  [email protected]
' 版权        ：  作者保留一切权力，
'                 请在公布本代码时将本段说明一起公布，谢谢！
'===========================================================
Private blnStopProcess As Boolean       '字段，决定是否终止操作。
Private dblTimerStart As Double         '操作时间
Private strCurrentFile As String        '当前正找到的文件
Public InitialFileName As String        '文件对话框开始的目录
Public Files As Dictionary              '将搜搜到符合条件的文件返回通过这个属性集合返回出去'公布一个事件，将目前处理进度返回给调用本类的程序
Public Event ProgressChange(ByVal percent As Double, ByVal runtime As Double, ByVal raiseSource As String, ByVal message As String)'公布选择文件的事件，让用户可以在类外部控制对应文件是否要操作
Public Event FileSearching(ByVal f As Scripting.File, ByRef cancel As Boolean)Public Property Let StopProcess(ByVal isStop As Boolean)
    blnStopProcess = isStop
End Property'与用户交互，选择一个目录
Function SelectFolder()
    Dim fd As Office.FileDialog
    Dim varSelect As Variant
    Dim fso As New Scripting.FileSystemObject
    Dim lngAC As Long
       
    '触发进度事件，将一切进度条归0
    RaiseEvent ProgressChange(0, 0, "File", "准备开始选择目录...")
    Set Files = New Dictionary
    
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    fd.AllowMultiSelect = True
    fd.InitialFileName = InitialFileName           'CurrentProject.Path & "\DiskClerk\CatalogLibrary"
    If fd.Show = True Then
        dblTimerStart = Timer()
        For Each varSelect In fd.SelectedItems
            lngAC = GetAllSubFile(fso.GetFolder(varSelect))
        Next
    End If
    RaiseEvent ProgressChange(1, Timer() - dblTimerStart, "File", "全部完成！" & lngAC & "个文件被找到。")
End Function
'统计某个目录中包含多少个子目录及文件。
Private Function GetAllSubFile(ByVal fld As Folder) As Long
    Dim f As File
    Dim fldSub As Folder
    Dim lngSubFileCount As Long
    Dim blnIsCanceled As Boolean
    Dim lngThisFolderFilesCount As Long
    
    '按客户指令终止程序
    If blnStopProcess = True Then
        blnStopProcess = False
        Exit Function
    End If
    
    lngSubFileCount = lngSubFileCount + 1
    
    For Each f In fld.Files
        lngThisFolderFilesCount = lngThisFolderFilesCount + 1
        
        '按客户指令终止程序
        If blnStopProcess = True Then
            blnStopProcess = False
            Exit Function
        End If
        
        RaiseEvent ProgressChange(lngThisFolderFilesCount / fld.Files.Count, Timer() - dblTimerStart, "File", f.Path)
        
        '找到的文件是否符合条件，由调用本类的程序来决定。
        blnIsCanceled = False
        RaiseEvent FileSearching(f, blnIsCanceled)
        If blnIsCanceled = False Then
            DoEvents
            strCurrentFile = f.Path
            Files.Add f.Path, f
            lngSubFileCount = lngSubFileCount + 1
        End If
    Next
    For Each fldSub In fld.SubFolders
        '按客户指令终止程序
        If blnStopProcess = True Then
            blnStopProcess = False
            Exit Function
        End If
        Debug.Print "folder", fldSub.Name
        lngSubFileCount = lngSubFileCount + GetAllSubFile(fldSub)
        DoEvents
    Next
    GetAllSubFile = lngSubFileCount
    
End Function
'''调用 clsSearchFile 类的演示
''Dim WithEvents sf As clsSearchFile
'''开始搜索
''Private Sub Command0_Click()
''    Set sf = New clsSearchFile
''    sf.SelectFolder
''End Sub
''
'''返回搜索结果
''Private Sub Command6_Click()
''    Dim i As Long
''    Dim k
''    Debug.Print sf.Files.Count
''    For i = 0 To sf.Files.Count - 1
''        Debug.Print TypeName(sf.Files.Items(i)), sf.Files.Items(i).Path
''        If i > 100 Then
''            Exit For
''        End If
''    Next
''End Sub
''
''Private Sub sf_ProgressChange(ByVal percent As Double, ByVal runtime As Double, ByVal raiseSource As String, ByVal message As String)
''    If percent <= 1 Then
''        Me.processBar.Width = Me.processBox.Width * percent
''    Else
''        Me.processBar.Width = Me.processBox.Width
''    End If
''    Me.processMessage.Caption = message
''    Me.processPercent.Caption = CInt(percent * 100) & "%"
''End Sub