还是文件查找问题

Question

现在要动态查找某一类型的文件或指定文件名查找，请帮忙！

Answer 1

呵呵，改动一下，试试看Private Sub Command4_Click()
    Dim i As Long
    Dim strFile() As String
    strFile = FindFile("C:\", "mdb")
    For i = 0 To UBound(strFile)
        Debug.Print strFile(i)
    Next
End SubFunction FindFile(strPath As String, strType As String) As String()
    Dim strFileName() As String
    Dim filename As String
    Dim j As Long
    j = -1
    filename = Dir(strPath & "\*." & strType)
    Do While filename <> ""
         If filename <> "." And filename <> ".." Then
              j = j + 1
              ReDim Preserve strFileName(j + 1)
              strFileName(j) = filename
         End If
         filename = Dir   ' 查找下一个文件。
    Loop
    FindFile = strFileName
End Function

Answer 2

Option Explicit
    Dim filesearch As String
    Dim findflag As Boolean
    
    '  清空搜索结果
    Private Sub clrcmd_Click()
        lstfiles.Clear
    End Sub
    
    '  开始查找文件
    Private Sub cmdgo_Click()
    Dim starttime As Single
    Dim i As Integer
    Dim Add As Boolean
    
    lstfiles.Clear '查找文件之前先清空结果
    lstdirs.Clear
    findflag = True '设置查找标志
    stopcmd.Enabled = True  '设置停止查找按钮为可用
    clrcmd.Enabled = False  '设置清空结果按钮为不可用
    starttime = Timer   '记录开始查找时刻
    filesearch = Combo1.Text
    '  将查找文件加入到组合框中
    For i = 0 To Combo1.ListCount - 1
        If Combo1.List(i) <> Combo1.Text Then
            Add = True
        Else
            Add = False
        End If
    Next
    If Add = True Then
        Combo1.AddItem (Combo1.Text)
    End If
    lstdirs.AddItem (Drive1.Drive & "\")
    '   执行查找文件
    Do
        status.Caption = "Searching . . . " & lstdirs.List(0)
        '  调用函数
        findfilesdir lstdirs.List(0)
        '  从目录列表中移除
        lstdirs.RemoveItem 0
        '  中途退出查找
        If findflag = False Then
          Exit Do
        End If
    Loop Until lstdirs.ListCount = 0
    stopcmd.Enabled = False
    clrcmd.Enabled = True
    
    '  显示查找文件的信息
    status.Caption = "用时" & Timer - starttime & "秒 " & "找到" & lstfiles.ListCount & "个文件"
    End Sub
    
    '  用来查找文件的函数
    Public Sub findfilesdir(DirPath As String)
    Dim filestring As String
    DirPath = Trim(DirPath)
    
    If Right(DirPath, 1) <> "\" Then
      DirPath = DirPath & "\"
    End If
    '  使用Dir函数获得DirPath目录下的文件或目录
    filestring = Dir(DirPath & "*.*", vbArchive Or vbHidden Or vbSystem Or vbDirectory)
    Do
      DoEvents '转让控制权，以便让操作系统处理其它的事件
      If filestring = "" Then
        Exit Do
      Else
        If (GetAttr(DirPath & filestring) And vbDirectory) Then
          If Left(filestring, 1) <> "." And Left(filestring, 2) <> ".." Then
            lstdirs.AddItem DirPath & filestring & "\"
          End If
        Else
          '  比较以确定是否是要查找的文件
          If (filestring Like filesearch) Then
          lstfiles.AddItem DirPath & filestring
          End If
        End If
      End If
      filestring = Dir '  返回其他文件名
    Loop
    End Sub
    
    '   结束退出
    Private Sub quitcmd_Click()
        Unload Me
        End
    End Sub
    
    '   停止查找
    Private Sub stopcmd_Click()
        findflag = False
        stopcmd.Enabled = False
    End Sub
    
    Private Sub Form_Load()
        Combo1.AddItem ("*.*")
    End Sub

Answer 3

还可以使用fso对象
Option Explicit
Dim FSO As Scripting.FileSystemObject
Dim SFlag As BooleanSub CheckFolder(strPath As String, fileN As String)
    Dim objFolder As Scripting.Folder '文件夹对象
    Dim objFile As Scripting.File '文件对象
    Dim objSubdirs As Scripting.Folders '文件夹集合对象
    Dim objLoopFolder As Scripting.Folder '文件夹对象
    Dim flag As Boolean
    
    '  获得目录
    Set objFolder = FSO.GetFolder(strPath)
    
    '  检查目录中的文件
    For Each objFile In objFolder.Files
        If objFile.Name Like fileN Then
            lstfiles.AddItem objFile.Path
        End If
    Next objFile
    
    '  是否停止
    If SFlag = False Then
        Exit Sub
    End If
    
    ' 在所有子目录中循环
    Set objSubdirs = objFolder.SubFolders
    For Each objLoopFolder In objSubdirs
        '递归调用CheckFolder子过程，实现目录树的遍历。
        CheckFolder objLoopFolder.Path, fileN
    Next objLoopFolder
    
    ' 释放对象所占内存
    Set objSubdirs = Nothing
    Set objFolder = Nothing
End Sub' 清空
Private Sub clrcmd_Click()
    lstfiles.Clear
    stopcmd.Enabled = False
End Sub'  查找
Private Sub cmdgo_Click()
    Set FSO = New Scripting.FileSystemObject
    SFlag = True
    stopcmd.Enabled = True
    CheckFolder Drive1.Drive, Combo1.Text
End Sub'  退出
Private Sub quitcmd_Click()
    End
End Sub'  停止
Private Sub stopcmd_Click()
    SFlag = False
End Sub