vb 取得文件夹名称的速度问题

Question

大家好，现在有一个问题想请教大家，问题是这样的，现在在服务器上某个共享目录下，假设是photo，下边有1000个后缀名不带back的文件夹，我现在要把这1000个文件夹的名称取出来显示在list里面，用下边的方法取的速度非常慢，想请教能不能有更好的方法让读取速度变快。谢谢各位了！
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set Fol = fso.GetFolder(strPath)
   Const DeleteReadOnly = True
   Set subD = Fol.SubFolders
   For Each f1 In subD
        If InStr(1, f1.Name, "_BACK", 1) = 0 Then
            List1.AddItem f1.Name
        End If
   Next

Answer 1

用API,以下是我用API编写的一个文件查找类,支持事件,速度相当快.
用法:新建一个空的类文件,将代码复制上去,然后在frm或cls文件中调用，bas不支持事件。查找结果将以回调形式反映给你的程序。
Option ExplicitPrivate 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 Const MAX_PATH = 260
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private 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 * MAX_PATH
    cAlternate As String * 14
End TypePublic Event Found(ByVal FileName As String, Cancel As Boolean)
Public Event Completed() '查找完成Dim m_Filter As String '通配符
Dim m_strFileExtNameList As String
Dim m_Cancel As Boolean '是否中止Sub Find(ByVal strStartPath As String, Optional ByVal FindInSubPath As Boolean = True)
    Dim lRet As Long
    Dim hFindFile As Long
    Dim strPath As String
    Dim strFileName As String
    Dim strFileExtName As String
    Static nCallCount As Long '调用次数
    Dim WFD As WIN32_FIND_DATA
    
    If Right(strStartPath, 1) = "\" Then
        strStartPath = strStartPath & "*.*"
    End If
    
    strPath = Left(strStartPath, Len(strStartPath) - 3)
    hFindFile = FindFirstFile(strStartPath, WFD)
    If hFindFile > 0 Then
        lRet = hFindFile
        Do While (lRet > 0) And (Not m_Cancel)
            strFileName = Left(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)) - 1)
            
            If Left(strFileName, 1) <> "." Then
                If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then '如果是路径
                    If FindInSubPath Then
                        nCallCount = nCallCount + 1 '加1
                        Call Find(strPath & strFileName & "\*.*", FindInSubPath) '递归调用
                        nCallCount = nCallCount - 1
                    End If
                Else '否则,为文件,发出事件通知
                    strFileExtName = GetFileExtendName(strFileName)
                    If m_strFileExtNameList = Space(5) Or InStr(m_strFileExtNameList, strFileExtName) > 0 Then
                        RaiseEvent Found(strPath & strFileName, m_Cancel)
                        If m_Cancel Then Exit Do '中止查找
                    End If
                End If
            End If
            lRet = FindNextFile(hFindFile, WFD)
            DoEvents
        Loop
        Call FindClose(hFindFile)
    End If
    If nCallCount = 0 Then RaiseEvent Completed
End SubPublic Property Get Filter() As String
    Filter = m_Filter
End Property
Public Property Let Filter(ByVal New_Filter As String)
    m_Filter = Filter
    m_strFileExtNameList = Analyze_WildCard(New_Filter) '设置扩展名列表
End PropertyPrivate Function GetFileExtendName(ByVal strFileName As String) As String '取得文件扩展名
    Dim nSite As Integer
    strFileName = Right(strFileName, 5)
    nSite = InStr(strFileName, ".")
    If nSite > 0 Then
        GetFileExtendName = UCase(Mid(strFileName, nSite + 1))
    End If
End FunctionPrivate Function Analyze_WildCard(ByVal strParam As String)  '分析通配符
    Dim strTemp As String
    Dim iStart As Integer, iNext As Integer, iTemp As Integer
    
    strParam = Trim(strParam)
    
    '截取路径符号"\"后的文件名(或文件名通配符)
    iStart = 0
    Do
        iNext = iStart + 1
        iStart = InStr(iNext, strParam, "\")
    Loop While iStart > 0
    strParam = UCase(Trim(Mid(strParam, iNext)))
    
    '如果为全部,则扩展名为5个空格
    If strParam = "*.*" Then
        Analyze_WildCard = Space(5)
        Exit Function
    End If
    
    '分解多个通配符
    iNext = 0
    Do
        iStart = iNext + 1
        iNext = InStr(iStart, strParam, ";")
        If iNext > 0 Then
            strTemp = Trim(Mid(strParam, iStart, iNext - iStart))
        Else
            strTemp = Trim(Mid(strParam, iStart))
        End If
        iTemp = InStr(strTemp, ".")
        If iTemp > 0 Then strTemp = Mid(strTemp, iTemp + 1)
        Analyze_WildCard = Analyze_WildCard & strTemp & Space(5 - Len(strTemp)) '生成如:txt_ _html_gif_ _格式的字符串,_表示空格
    Loop While iNext > 0
End Function
Private Sub Class_Initialize()
    m_Filter = "*.*"
    m_strFileExtNameList = Space(5) '扩展名列表,默认为5个空格
End Sub

Answer 2

另外，在使用List控件时，如果数量过大，速度将明显降低，如果只是为了显示，你可以使用其它控件（如表格控件）

Answer 3

strFile = Dir(strPath & "\*.*", vbDirectory)List1.Visible = False
List1.Clear
Do Until strFile = ""
    If Right(strFile, 5) <> ""_BACK" Then List1.AddItem strFile
    strFile = Dir()
Loop
List1.Visible = True1 不要用 InStr 全长查找
2 添加过程中关闭 ListBox 可视属性，避免刷新

Answer 4

呵呵....不会有人比我的快了, 楼主再不满意应该再也没其它办法了.这是我数月前被一个印刷厂整出来的经验, 数百万张的图片遍历局域网的搜索, 我足足搞了两天两夜才摆平这个客户.'添加 List1 Command1Dim FolderPath$, TxtName$, Starttm&
Private Sub Form_Load()
   TxtName = "c:\dir.txt"
   FolderPath = "e:\pictures"
End SubPrivate Sub Command1_Click()
   On Error Resume Next
   If Dir(FolderPath, vbDirectory) = "" Then MsgBox "bb": Exit Sub
   If Dir(TxtName) <> "" Then Kill TxtName
   Open "c:\SchDir.bat" For Output As #1
   Print #1, "@echo off"
   Print #1, "dir " & FolderPath & " /ad/s/b >" & TxtName
   Print #1, "exit"
   Close #1
   Call Shell("c:\schdir.bat", vbHide)
   Starttm = Timer
   Do
      DoEvents
      If Dir(TxtName) <> "" Then
         If FileLen(TxtName) > 50 Then Exit Do '50也是一个大概予估数,自己测一下10 20 100 200都行
      End If
   Loop Until Timer >= Starttm + 5 '最多5秒,看你要搜的路径大小自己看着办
   List1.Visible = False '暂时关闭会快N倍
   If Dir(TxtName) <> "" Then
      Open TxtName For Input As #1
      List1.Clear
      While Not EOF(1)
         Line Input #1, aa
         If InStr(aa, "_BACK") = 0 Then List1.AddItem aa
      Wend
      Close #1
   End If
   List1.Visible = True
   If Dir(TxtName) <> "" Then Kill TxtName
   Kill "c:\SchDir.bat"
End Sub

Answer 5

读的时候把文件夹名先存在一个数组里，读完之后再在with块内更新至list，更新的时候用上of123的方法
不过提醒一点，vb里面的控件操作你再怎么想办法也别想快到哪里去，先天缺陷

Answer 6

FSO 递归算法 以及API的Find...我都用过了,呵呵, 速度还是靠边站了.上面方法 我加了 /s 参数,连子目录也全部搜, 不搜子目录的话 1000个文件夹最多不超2-3秒就可搞定.

Answer 7

吐血。。2-3秒，你的方法还有待改进
你把你的代码按照我的方法稍微改一下，看看
另外，把folderpath和"_back"用const声明
添加的时候
  with list1
      .visible=false
       for i=0 to ubound(fldnmae)'这个是存储文件夹名字的数组
         .additem  fldname(i) ,i
       next
     .visible=true
  end with
我自己测试的时候，就直接用FSO，用windows文件夹试的，只有113个子文件夹，瞬间完成。

Answer 8

呵呵, 楼上的,试试看再吐吧, 我的E盘40G, e:\pictures 占了12G,用2-3秒已经是比较保守的说法了,整盘我用了6秒多共搜到7391个文件夹,(图片验证),你试试你的吧.还有我的代码是 "**** 遍历下层的所有子文件夹 ****" ,非指定的那一层而已.楼主这个需求重点在于前期文件或数组的取得, 这才是速度的关键,10F的代码是后期的处理,在整个需求来说,后期的处理已经没多大差别了.你何不试试搜一下你最大的盘符, 路径就是 c:\ d:\ 或 e:\ 不就见真假了吗 ?楼主请再找我, 你留言的问题我用了另种方法解决了,不再用FileLen退出,不会再有你说的问题了.测试时间图:
http://p.blog.csdn.net/images/p_blog_csdn_net/cbm666/366646/o_DIRSCH.jpg