vba查找文件的问题
我需要做一个查找指定目录下的相关文件功能
指定目录（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种文件）
[解决办法]
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
[解决办法]
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) '读出每一个文件名称 NextEnd SubPrivate 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 = FileNameEnd Function
[解决办法]
Option ExplicitPrivate Const LB_ADDSTRING = &H180Private Const WM_SETREDRAW = &HBPrivate Const WM_VSCROLL = &H115Private Const SB_BOTTOM = 7Private Const INVALID_HANDLE_VALUE = -1Private Const vbKeyDot = 46Private Type FILETIME dwLowDateTime As Long dwHighDateTime As LongEnd 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 * 14End TypePrivate 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 LongPrivate Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As LongPrivate Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As LongPrivate Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As LongPrivate Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As LongPrivate Const DRIVE_CDROM = 5Private Const DRIVE_FIXED = 3Private Const DRIVE_RAMDISK = 6Private Const DRIVE_REMOTE = 4Private Const DRIVE_REMOVABLE = 2Dim FindNumber As IntegerDim Programme1, Programme2, MyPath As StringDim RunTime As IntegerDim files1$, files2%Dim TotalDirs%, TotalFiles%, Running%Dim www As WIN32_FIND_DATA, fitem&, ffile&Dim driveName As StringPublic cSearchResult As StringPrivate 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 IfEnd SubPrivate Sub Combo1_Change() files1$ = Combo1.TextEnd SubPrivate Sub Combo1_Click() files1$ = Combo1.TextEnd 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 Ifcjl: 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_ClickEnd SubPrivate Sub Command2_Click() Unload Me EndEnd SubPrivate Sub Drive1_Change() driveName = Drive1.DriveEnd 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
[解决办法]
支持进度条的文件搜索
方法二：
用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
' 电子邮件 ： access911@gmail.com
' 版权 ： 作者保留一切权力，
' 请在公布本代码时将本段说明一起公布，谢谢！
'===========================================================
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