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

[lanyu1014]

大家好，现在有一个问题想请教大家，问题是这样的，现在在服务器上某个共享目录下，假设是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

[lyserver]

用API,以下是我用API编写的一个文件查找类,支持事件,速度相当快.
用法:新建一个空的类文件,将代码复制上去,然后在frm或cls文件中调用，bas不支持事件。查找结果将以回调形式反映给你的程序。
Option Explicit

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 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 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 * MAX_PATH
cAlternate As String * 14
End Type

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

Public 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 Property

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

Private 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

[lyserver]

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

[lanyu1014]

谢谢楼上的回答，请问有没有简单一点的答案呢，因为我刚开始用vb，这个方法我有些读不懂，用不明白，多谢指教。

[lanyu1014]

而且我现在要取的是文件夹的名称，不是文件的名称。

[of123]

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 = True

1 不要用 InStr 全长查找
2 添加过程中关闭 ListBox 可视属性，避免刷新

[lanyu1014]

速度还是很慢，能不能换个方法来解决这个问题呢。多谢了！

[cbm6666]

呵呵....不会有人比我的快了, 楼主再不满意应该再也没其它办法了.

这是我数月前被一个印刷厂整出来的经验, 数百万张的图片遍历局域网的搜索, 我足足搞了两天两夜才摆平这个客户.

'添加 List1 Command1

Dim FolderPath$, TxtName$, Starttm&
Private Sub Form_Load()
TxtName = "c:\dir.txt"
FolderPath = "e:\pictures"
End Sub

Private 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

[forbearORfolie]

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

[cbm6666]

FSO 递归算法 以及API的Find...我都用过了,呵呵, 速度还是靠边站了.

上面方法 我加了 /s 参数,连子目录也全部搜, 不搜子目录的话 1000个文件夹最多不超2-3秒就可搞定.

[forbearORfolie]

吐血。。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个子文件夹，瞬间完成。

[cbm6666]

呵呵, 楼上的,试试看再吐吧, 我的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