您的位置: 首页  >  IT文章  >  vba查找文件的有关问题

vba查找文件的有关问题

分类: IT文章 • 2022-10-17 00:06:48
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种文件）



------解决方案--------------------
VB code
 
 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

------解决方案--------------------
VB code

Option Explicit

Private 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

------解决方案--------------------
VB code
Option Explicit

Private 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 = 46

Private Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type

Private 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 Integer

Dim 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 Sub

Private 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 Sub





Private Sub Combo1_Change()
        files1$ = Combo1.Text
End Sub

Private Sub Combo1_Click()
        files1$ = Combo1.Text
End Sub

Private 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 Sub

Private Sub Command2_Click()
        Unload Me
        End
End Sub

Private Sub Drive1_Change()
        driveName = Drive1.Drive
End Sub





Private 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 Sub



Private 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

相关推荐