none
这个搜索为何CPU使用率这么高? 谁能帮我改一下 RRS feed

  • 问题


  • Option Explicit
    Public Const INVALID_HANDLE_VALUE = -1

    Public Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

    Public Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

    Public Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

    '最大路径长度和文件属性常量的定义

    Public Const MAX_PATH = 260

    Public Const FILE_ATTRIBUTE_ARCHIVE = &H20

    Public Const FILE_ATTRIBUTE_COMPRESSED = &H800

    Public Const FILE_ATTRIBUTE_DIRECTORY = &H10

    Public Const FILE_ATTRIBUTE_HIDDEN = &H2

    Public Const FILE_ATTRIBUTE_NORMAL = &H80

    Public Const FILE_ATTRIBUTE_READONLY = &H1

    Public Const FILE_ATTRIBUTE_SYSTEM = &H4

    Public Const FILE_ATTRIBUTE_TEMPORARY = &H100

    '自定义数据类型FILETIME和WIN32_FIND_DATA的定义

    Public Type FILETIME
       
        dwLowDateTime As Long
       
        dwHighDateTime As Long
       
    End Type

    Public 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 mStopSearch As Boolean


    Dim WFD As WIN32_FIND_DATA, hItem&, hFile&
    Dim dirCount&, lFileCount&, i&
    Dim filepath$
    Dim dirArray$()
    Dim dwFileAttributes As Long


    Public Sub SearchDirs(filepath$)
       
        Dim WFD As WIN32_FIND_DATA, hItem&, hFile&
        Dim dirCount&, i&
        Dim dirArray$()
       
        DoEvents
       
        If Right(filepath$, 1) <> "\" Then filepath$ = filepath$ & "\"
        hItem& = FindFirstFile(filepath$ & "*", WFD)
       
        If hItem& <> INVALID_HANDLE_VALUE Then
           
            Do
               
                If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
                    '排除 "." or ".." DOS 子目录,Asc(.)=46
                    If Asc(WFD.cFileName) <> 46 Then
                        '重新分配数组当目录数单位为10个块,加快操作速度
                        If (dirCount& Mod 3) = 0 Then ReDim Preserve dirArray(dirCount& + 20)
                        dirCount& = dirCount& + 1
                        'ReDim Preserve dirArray(dirCount&) ,也可以即时分配内存
                       
                        dirArray(dirCount&) = Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
                       
                    End If
                   
                   
                End If
               
               
            Loop While FindNextFile(hItem&, WFD) '获取下一个子目录
            '关闭查找文件的句柄
            Call FindClose(hItem&)      '关闭FindFirstFile
           
        End If
       
       
       
        hFile& = FindFirstFile(filepath$ & "*.*", WFD)
       
        If hFile& <> INVALID_HANDLE_VALUE Then
           
            Do
               
                DoEvents
               
                If Not mStopSearch Then Exit Sub
               
                '排除 "." or ".." DOS 子目录,Asc(.)=46
                If Asc(WFD.cFileName) <> 46 Then
                    lFileCount = lFileCount + 1
                    Form1.Label1.Caption = lFileCount & filepath$ & WFD.cFileName
                End If
               
            Loop While FindNextFile(hFile&, WFD)
           
            Call FindClose(hFile&)
           
        End If
       
       
       
        For i& = 1 To dirCount&
           
            SearchDirs filepath$ & dirArray(i&) & "\"
           
        Next i&
       
        Erase dirArray()
       
       
    End Sub
       
       

    2010年8月11日 1:45

答案

全部回复