locfile1.frm

查找文件

VERSION 5.00
Begin VB.Form frmLocate 
   AutoRedraw      =   -1  'True
   Caption         =   "File Data"
   ClientHeight    =   5010
   ClientLeft      =   105
   ClientTop       =   1770
   ClientWidth     =   6555
   LinkTopic       =   "Form1"
   ScaleHeight     =   20.875
   ScaleMode       =   4  'Character
   ScaleWidth      =   54.625
   Begin VB.Frame Frame1 
      Height          =   4935
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Visible         =   0   'False
      Width           =   6495
      Begin VB.CommandButton cmdAction 
         Caption         =   "Cancel"
         Height          =   375
         Index           =   1
         Left            =   1680
         TabIndex        =   4
         Top             =   3720
         Width           =   1335
      End
      Begin VB.Frame Options 
         Caption         =   "Search Options"
         Height          =   855
         Left            =   3120
         TabIndex        =   7
         Top             =   3240
         Width           =   3255
         Begin VB.CheckBox Check1 
            Caption         =   "Include Sub Directories"
            Height          =   255
            Index           =   0
            Left            =   240
            TabIndex        =   8
            Top             =   240
            Value           =   1  'Checked
            Width           =   2055
         End
      End
      Begin VB.ListBox List1 
         Height          =   2205
         Left            =   3000
         Sorted          =   -1  'True
         TabIndex        =   9
         Top             =   960
         Width           =   3375
      End
      Begin VB.TextBox Text1 
         Height          =   375
         Left            =   3000
         TabIndex        =   6
         Top             =   480
         Width           =   3375
      End
      Begin VB.CommandButton cmdAction 
         Caption         =   "Find Files"
         Enabled         =   0   'False
         Height          =   375
         Index           =   0
         Left            =   120
         TabIndex        =   3
         Top             =   3720
         Width           =   1455
      End
      Begin VB.DirListBox Dir1 
         Height          =   3015
         Left            =   120
         TabIndex        =   2
         Top             =   240
         Width           =   2775
      End
      Begin VB.DriveListBox Drive1 
         Height          =   315
         Left            =   120
         TabIndex        =   1
         Top             =   3360
         Width           =   2775
      End
      Begin VB.Label Label1 
         Caption         =   "Search String"
         Height          =   255
         Left            =   3000
         TabIndex        =   10
         Top             =   240
         Width           =   1455
      End
      Begin VB.Label Status 
         BorderStyle     =   1  'Fixed Single
         Height          =   615
         Left            =   120
         TabIndex        =   5
         Top             =   4200
         Width           =   6255
      End
   End
   Begin VB.Menu mnuFile 
      Caption         =   "&File"
      Begin VB.Menu mnuFileSub 
         Caption         =   "E&xit"
         Index           =   9
      End
   End
End
Attribute VB_Name = "frmLocate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'********************************************************
' REQUIRES:
' Reference to Microsoft Scripting Runtime
'
'#########################################################

Private objFSO As FileSystemObject, I As Integer, G As Integer
Private objFiles As Files, objFile As File, lngRtn As Long
Private objFolders As Folders, objFolder As Folder, FileCount() As Integer
Private lngFNAMEScntr As Long, FPaths() As String
Private Cancel As Boolean, AppPath As String, pass As Boolean
Private Const LB_SETHORIZONTALEXTENT = &H194

Private Declare Function SendMessage _
Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long

Public Sub FindFiles(strPARENT As String, strPaths() As String, FindFile As String)
    
    'EXAMPLE:
    ' FindFiles Dir1.Path, arrayPointers, arrayFilenames
    On Error GoTo ErrorH
    
    'The result in is used to fill a listbox.
    If FindFile = "" Then Exit Sub
    Dim lngTopIndex As Long, lngPathIndex As Long, strNextPath As String
    Dim UStart As Boolean, UEnd As Boolean, Found As Boolean, StrSize As Long
    ReDim FType(2, 0)
    Dim FileName() As String, FileNo As Single, UFlag() As Boolean, Matches As Integer
    ReDim FileName(1)
    FileNo = 1
    FileNo = InStr(FileNo, FindFile, ";", vbTextCompare)
    FileName(0) = Mid(FindFile, 1, IIf(FileNo > 0, FileNo - 1, Len(FindFile)))
    Do While FileNo <> 0
        ReDim Preserve FileName(UBound(FileName) + 1)
        FileName(UBound(FileName) - 1) = Mid(FindFile, FileNo + 1, IIf(FileNo > 0, _
        IIf(InStr(FileNo + 1, FindFile, ";", vbTextCompare) > 0, InStr(FileNo + 1, _
        FindFile, ";", vbTextCompare) - (FileNo + 1), Len(FindFile) - FileNo), FileNo - 1))
        FileNo = InStr(FileNo + 1, FindFile, ";", vbTextCompare)
    Loop
    ReDim UFlag(3, UBound(FileName))
    ReDim FileCount(UBound(FileName))
    G = 1
    For I = 0 To UBound(FileName) - 1
        UFlag(0, I) = False
        UFlag(1, I) = False
        UFlag(2, I) = False
        Do
            G = InStr(G, FileName(I), "*")
            If G = 1 Then
                UFlag(0, I) = True
                FileName(I) = Right(FileName(I), (Len(FileName(I)) - 1))
            End If
            If G = Len(FileName(I)) Then
                UFlag(1, I) = True
                FileName(I) = Left(FileName(I), Len(FileName(I)) - 1)
            End If
            If G <> 0 Or G = Len(FileName(I)) Then G = G + 1
        Loop Until G = 0
        G = 1
    Next
    'Remove *s form the search string
    ' "seed" the loop
    lngTopIndex = 0
    lngPathIndex = 0
    lngFNAMEScntr = 0
    ReDim strPaths(0)
    strPaths(0) = IFBACKSLASH(strPARENT)
    
    Do
        If Check1(0) Then 'SubFolders
            'Creates a folders object containing the subfolders and files
            Set objFolders = objFSO.GetFolder(strPaths(lngPathIndex)).SubFolders
            ' Add subfolders, if any, to folder array
            For Each objFolder In objFolders
                'Increment the folder counter
                lngTopIndex = lngTopIndex + 1
                'Create an additional element in the array
                ReDim Preserve strPaths(lngTopIndex)
                'Store the previous path and the current folder to the path array
                strPaths(lngTopIndex) = strPaths(lngPathIndex) & objFolder.Name & "\"
            Next
        End If
        Set objFiles = objFSO.GetFolder(strPaths(lngPathIndex)).Files
        Status = strPaths(lngPathIndex)
        DoEvents
        ' Add filenames, if any, to array
        For Each objFile In objFiles
            Found = False
            'No Wildcards looks for the exact file name
            For I = 0 To UBound(FileName) - 1
                'This next section determines if there is a wild card indicator before
                'and or after the string to locate
                If Not UFlag(0, I) And Not UFlag(1, I) And Not UFlag(2, I) Then
                    If objFSO.FileExists(strPaths(lngPathIndex) & FileName(I)) Then
                        List1.AddItem strPaths(lngPathIndex) & FileName(I)
                        UFlag(2, I) = True
                        FileCount(I) = FileCount(I) + 1
                    End If
               End If
                If Len(objFile.Name) <= Len(FileName(I)) Then Exit For
                'If the wild card indicator is before and after all finds are located
                If UFlag(0, I) And UFlag(1, I) Then
                    If InStr(1, UCase(objFile.Name), UCase(FileName(I))) > 0 Then Found = True
                End If
                'Identifies only those filenames with the Wildcard at the start of the string
                If UFlag(0, I) And Not UFlag(1, I) Then
                    If InStr((Len(objFile.Name) - Len(FileName(I))), UCase(objFile.Name), UCase(FileName(I))) > 0 Then Found = True
                End If
                'Identifies only those file names with a Wildcard at the end of the string
                If UFlag(1, I) And Not UFlag(0, I) Then
                    If InStr(1, Left(UCase(objFile.Name), Len(FileName(I))), UCase(FileName(I))) > 0 Then Found = True
                End If
                If Found Then
                    List1.AddItem objFile.Path & "   " & objFile.Size & "   " & objFile.DateLastModified
                    If frmLocate.TextWidth(objFile.Path & "   " & objFile.Size & "   " & objFile.DateLastModified) > StrSize Then
                        StrSize = frmLocate.TextWidth(objFile.Path & "   " & objFile.Size & "   " & objFile.DateLastModified)
                    End If
                    FileCount(I) = FileCount(I) + 1
                    Exit For
                End If
                If Cancel Then
                    MousePointer = 0
                    Exit Sub
                End If
            Next
        Next
          
        ' Point to next entry in subfolder array
          lngPathIndex = lngPathIndex + 1
          
        ' If there are no more subfolders, exit
    Loop Until lngPathIndex > lngTopIndex
    lngRtn = SendMessage(List1.hwnd, LB_SETHORIZONTALEXTENT, _
        StrSize * 9, ByVal 0&)
        Status = ""
        For I = 0 To UBound(FileCount) - 1
            Status = Status & "    " & FileName(I) & " - " & FileCount(I)
        Next
    Status = List1.ListCount & "  Files Found  " & Status
    Exit Sub

ErrorH:
    Stop
    Resume Next
End Sub


Public Sub Terminate()
    ' Clear all the objects from memory
     Set objFSO = Nothing
     Set objFiles = Nothing
     Set objFile = Nothing
     Set objFolders = Nothing
     Set objFolder = Nothing
End Sub

Private Function IFBACKSLASH(strX As String) As String
    ' function for fixing the DOS path of a root directory
     IFBACKSLASH = IIf(Right(strX, 1) = "\", strX, strX & "\")
End Function



Private Sub cmdAction_Click(Index As Integer)
    Select Case cmdAction(Index).Caption
        Case "&Find Files"
            MousePointer = 11
            List1.Clear
            Cancel = False
            FindFiles Dir1.Path, FPaths(), Text1
            If Cancel Then Exit Sub
            'List1.Sorted = True 'Check1(0)
            MousePointer = 0
        Case "Cancel"
            Cancel = True
    End Select
End Sub

Private Sub Dir1_Change()
    Check1(0) = False
    MousePointer = 11
    List1.Clear
    Cancel = False
    FindFiles Dir1.Path, FPaths(), Text1
    If Cancel Then Exit Sub
    'List1.Sorted = True 'Check1(0)
    MousePointer = 0
End Sub

Private Sub Drive1_Change()
    Dir1.Path = Drive1.Drive
End Sub

Private Sub Form_Load()
    AppPath = IFBACKSLASH(App.Path)
    Drive1.Drive = AppPath
    Dir1.Path = AppPath
    'PURPOSE: Create & initialize objFSO as a FileSystemObject object.
    Set objFSO = New FileSystemObject
    cmdAction(0).Caption = "&Find Files"
    Frame1.Visible = True
End Sub

Private Sub mnuFileSub_Click(Index As Integer)
    Select Case mnuFileSub(Index).Caption
        Case "E&xit"
            End
    End Select
End Sub

Private Sub Text1_Change()
    If cmdAction(0).Enabled = False And Text1 <> "" Then cmdAction(0).Enabled = True
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then cmdAction_Click 0
End Sub