search.bas

OpenPlayer代码

Attribute VB_Name = "Search"
Option Explicit
'===========================================================
'文件搜索的模块,这个是拿来的
'如果要学习搜索文件的功能,
'我这里有一个专门制作的例子
'[e-mail]
'===========================================================




' This message helps speed up the initialization of list boxes that have a large number
' of items (more than 100). It preallocates the specified amount of memory so that
' subsequent LB_ADDSTRING, LB_INSERTSTRING, LB_DIR, and LB_ADDFILE
' messages take the shortest possible time. You can use estimates for the wParam and
' lParam parameters. If you overestimate, some extra memory is allocated; if you
' underestimate, the normal allocation is used for items that exceed the preallocated amount.
' wParam:          Specifies the number of items to add.
' lParam:           Specifies the amount of memory, in bytes, to allocate for item strings.
' Return Value:   The return value is the maximum number of items that the memory
                       ' object can store before another memory reallocation is needed, if
                       ' successful. It is LB_ERRSPACE if not enough memory is available.
Public Const LB_INITSTORAGE = &H1A8

' An application sends an LB_ADDSTRING message to add a string to a list box.
' If the list box does not have the LBS_SORT style, the string is added to the end
' of the list. Otherwise, the string is inserted into the list and the list is sorted.
Public Const LB_ADDSTRING = &H180

Public Const WM_SETREDRAW = &HB
Public Const WM_VSCROLL = &H115
Public Const SB_BOTTOM = 7

' If the function succeeds, the return value is a bitmask
' representing the currently available disk drives. Bit
' position 0 (the least-significant bit) is drive A, bit position
' 1 is drive B, bit position 2 is drive C, and so on.
' If the function fails, the return value is zero.
Declare Function GetLogicalDrives Lib "Kernel32" () As Long

' If the function succeeds, the return value is a search handle
' used in a subsequent call to FindNextFile or FindClose
Declare Function FindFirstFile Lib "Kernel32" Alias "FindFirstFileA" _
                        (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

'FindFirstFile failure rtn value
Public Const INVALID_HANDLE_VALUE = -1

' Rtns True (non zero) on succes, False on failure
Declare Function FindNextFile Lib "Kernel32" Alias "FindNextFileA" _
                        (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

' Rtns True (non zero) on succes, False on failure
Declare Function FindClose Lib "Kernel32" (ByVal hFindFile As Long) As Long

Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type

Public Const MaxLFNPath = 260

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 * MaxLFNPath
        cShortFileName As String * 14
End Type
' Brought to you by Brad Martinez
' http://members.aol.com/btmtz/vb

' Though this example has been optimized for speed,
' it's obviously not as efficient as it could be.
' Consider it a starting point...

' A liberal use of module level variables...
Dim PicHeight%, hLB&, FileSpec$, UseFileSpec%
Dim TotalDirs%, TotalFiles%

Public running As Boolean
Dim FilesCounter As Integer

' These variables are allocated at the module level to save on
' stack space & on variable re-allocation time in SearchDirs().
' They could be declared as Static within their respective procs...
Dim WFD As WIN32_FIND_DATA, hItem&, hFile&

' SearchDirs() constants
Const vbBackslash = "\"
Const vbAllFiles = "*.*"
Const vbKeyDot = 46

Sub SearchFile(lLBhwnd As Long)
If running Then
   running = False
   ControlForm.StatusFrame.Visible = False
   ControlForm.ImgSearch.Picture = ControlForm.CtrlImageBase(6).Picture
   ControlForm.ImgSearch.ToolTipText = "搜索盘上所有Flash 动画文件"
   Exit Sub
End If
    ControlForm.List(4).Clear
    ControlForm.List(5).Clear
    ControlForm.StatusFrame.Visible = True
    ControlForm.ImgSearch.Picture = ControlForm.CtrlSwapImage(6).Picture
    ControlForm.ImgSearch.ToolTipText = "停止搜索"
    hLB& = lLBhwnd
    Dim drvbitmask&, maxpwr%, pwr%
    On Error Resume Next
    
    FileSpec$ = "*.swf"
    
    ' A parsing routine could be implemented here for
    ' multiple file spec searches, i.e. "*.bmp,*.wmf", etc.
    ' See the MS KB article Q130860 for information on how
    ' FindFirstFile() does not handle the "?" wildcard char correctly !!
    
    If Len(FileSpec$) = 0 Then Exit Sub
    
    running = True
    UseFileSpec% = True
   
    
    'List1.Clear
    
    ' The following code block is used to demonstrate how
    ' to search every available drive on a system.
    ' See the "Browse for Folder" demo for an example of
    ' selecting individual drives or folders for a search.
    
    ' http://members.aol.com/btmtz/vb/browsdlg
    
    drvbitmask& = GetLogicalDrives()
    ' If GetLogicalDrives() succeeds, the return value is a bitmask representing
    ' the currently available disk drives. Bit position 0 (the least-significant bit)
    ' is drive A, bit position 1 is drive B, bit position 2 is drive C, and so on.
    ' If the function fails, the return value is zero.
    ' GetLogicalDriveStrings() could be used here instead,
    ' but it's string buffer would have to be parsed...
    If drvbitmask& Then
        
        ' Get & search each available drive
        maxpwr% = Int(Log(drvbitmask&) / Log(2))   ' a little math...
       For pwr% = 0 To maxpwr%
           If running And (2 ^ pwr% And drvbitmask&) Then _
              Call SearchDirs(Chr$(vbKeyA + pwr%) & ":\", "正在搜索：", ControlForm.List(5))
                DoEvents
       Next
    End If
   
    
    running = False
    UseFileSpec% = False
    ControlForm.StatusFrame.Visible = False
    ControlForm.ImgSearch.Picture = ControlForm.CtrlImageBase(6).Picture
    ControlForm.ImgSearch.ToolTipText = "搜索盘上所有Flash 动画文件"
End Sub



'======================================================
' This is were it all happens...

' You can use the values in returned in the
' WIN32_FIND_DATA structure to virtually obtain any
' information you want for a particular folder or group of files.

' This recursive procedure is similar to the Dir$ function
' example found in the VB3 help file...
Sub AddToFolder(strFolder As String, lLBhwnd As Long)
If running Then
   running = False
   ControlForm.StatusFrame.Visible = False
   Exit Sub
End If
    ControlForm.List(4).Clear
    ControlForm.List(5).Clear
    ControlForm.StatusFrame.Visible = True
    hLB& = lLBhwnd
    Dim drvbitmask&, maxpwr%, pwr%
    On Error Resume Next
    
    FileSpec$ = "*.swf"
   
    
    If Len(FileSpec$) = 0 Then Exit Sub
    
    running = True
    UseFileSpec% = True
    
    Call SearchDirs(strFolder, "正在添加：", ControlForm.List(1))
    
    running = False
    UseFileSpec% = False
    ControlForm.StatusFrame.Visible = False
   
   
End Sub

Private Sub SearchDirs(curpath$, StatusText As String, oList As ListBox)  ' curpath$ is passed w/ trailing "\"

    ' These can't be static!!! They must be
    ' re-allocated on each recursive call.
    Dim dirs%, dirbuf$(), i%
    
    ' Display what's happening...
    ' A Timer could be used instead to display status at
    ' pre-defined intervals, saving on PictureBox redraw time...
    '  Sl.Caption = "正在搜索：" & curpath$
    
    ' Allows the PictureBox to be redrawn
    ' & this proc to be cancelled by the user.
    ' It's not necessary to have this in the loop
    ' below since the loop works so fast...
    DoEvents

    If Not running Then Exit Sub
    
    ' This loop finds *every* subdir and file in the current dir
    hItem& = FindFirstFile(curpath$ & vbAllFiles, WFD)
    
    If hItem& <> INVALID_HANDLE_VALUE Then
        
        Do
            ' Tests for subdirs only...
            If (WFD.dwFileAttributes And vbDirectory) Then
                
                ' If not a  "." or ".." DOS subdir...
                If Asc(WFD.cFileName) <> vbKeyDot Then
                    ' This is executed in the mnuFindFiles_Click()
                    ' call though it isn't used...
                    TotalDirs% = TotalDirs% + 1
                    ' This is the heart of a recursive proc...
                    ' Cache the subdirs of the current dir in the 1 based array.
                    ' This proc calls itself below for each subdir cached in the array.
                    ' (re-allocating the array only once every 10 itinerations improves speed)
                    If (dirs% Mod 10) = 0 Then ReDim Preserve dirbuf$(dirs% + 10)
                    dirs% = dirs% + 1
                    dirbuf$(dirs%) = Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
                End If
                
             ControlForm.StatusLabel.Caption = StatusText & curpath$
             ControlForm.StatusLabel.ToolTipText = curpath$
            ' File size and attribute tests can be used here, i.e:
            ' ElseIf (WFD.dwFileAttributes And vbHidden) = False Then  'etc...
            
            ' Get a total file count for mnuFolderInfo_Click()
            ElseIf Not UseFileSpec% Then
                TotalFiles% = TotalFiles% + 1
            End If
        
        ' Get the next subdir or file
        Loop While FindNextFile(hItem&, WFD)
        
        ' Close the search handle
        Call FindClose(hItem&)
    
    End If

    ' When UseFileSpec% is set mnuFindFiles_Click(),
    ' SearchFileSpec() is called & each folder must be
    ' searched a second time.
    If UseFileSpec% Then
        ' Turning off painting speeds things quite a bit...
        ' Speed also would be vastly improved if the redrawing
        ' & scrolling were placed in a Timer event...
       '====================SendMessage hLB&, WM_SETREDRAW, 0, 0
        Call SearchFileSpec(curpath$, oList)
        ' Keeps the currently found items scrolled into view...
       '==================== SendMessage hLB&, WM_VSCROLL, SB_BOTTOM, 0
       '===================== SendMessage hLB&, WM_SETREDRAW, 1, 0
    End If
    
    ' Recursively call this proc & iterate through each subdir cached above.
    For i% = 1 To dirs%
         SearchDirs curpath$ & dirbuf$(i%) & vbBackslash, StatusText, oList
    Next i%
  
End Sub

Private Sub SearchFileSpec(curpath$, oList As ListBox)   ' curpath$ is passed w/ trailing "\"
' This procedure *only*  finds files in the
' current folder that match the FileSpec$
    
    hFile& = FindFirstFile(curpath$ & FileSpec$, WFD)
    If hFile& <> INVALID_HANDLE_VALUE Then
        
        Do
            ' Use DoEvents here since we're loading a ListBox and
            ' there could be hundreds of files matching the FileSpec$
            DoEvents
            
            If Not running Then Exit Sub
            
            ' The ListBox's Sorted property is initially set to False.
            ' Set it to True and see how things slow down a bit...
             FilesCounter = FilesCounter + 1
             
            SendMessage hLB&, LB_ADDSTRING, 0, _
                ByVal "[" & oList.ListCount + 1 & "]" & Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1) '取得纯文件名
                                 
           oList.AddItem (curpath$ & Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1))
            
            
          '  strFoundFile(FileCount) = curpath$ & Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
             
        ' Get the next file matching the FileSpec$
        Loop While FindNextFile(hFile&, WFD)
        
        ' Close the search handle
        Call FindClose(hFile&)
    
    End If

End Sub