Programming Tool Box/SIMS_2.iso/vb_code1/findfile/findfile.frm

Text File | 1994-05-20 | 6KB | 252 lines

VERSION 2.00
Begin Form FindFile
   BackColor       =   &H00C0C0C0&
   Caption         =   "Find File"
   ClientHeight    =   2520
   ClientLeft      =   1095
   ClientTop       =   1590
   ClientWidth     =   7365
   Height          =   2925
   Icon            =   FINDFILE.FRX:0000
   Left            =   1035
   LinkTopic       =   "Form1"
   ScaleHeight     =   2520
   ScaleWidth      =   7365
   Top             =   1245
   Width           =   7485
   Begin CommandButton CancelBtn
      Caption         =   "Cancel"
      Height          =   510
      Left            =   5850
      TabIndex        =   5
      Top             =   1710
      Visible         =   0   'False
      Width           =   1230
   End
   Begin CommandButton OKBtn
      Caption         =   "OK"
      Height          =   510
      Left            =   5850
      TabIndex        =   4
      Top             =   1125
      Width           =   1230
   End
   Begin TextBox Containing
      Height          =   285
      Left            =   4095
      TabIndex        =   1
      Top             =   675
      Width           =   2985
   End
   Begin SSCheck IncludeSub
      Alignment       =   1  'Right Justify
      Caption         =   "Include Subdirectories"
      Height          =   285
      Left            =   2925
      TabIndex        =   2
      Top             =   1260
      Value           =   -1  'True
      Width           =   2220
   End
   Begin TextBox FileSpec
      Height          =   285
      Left            =   4635
      MaxLength       =   12
      TabIndex        =   0
      Text            =   "*.*"
      Top             =   180
      Width           =   2445
   End
   Begin DirListBox Dir1
      Height          =   2055
      Left            =   315
      TabIndex        =   6
      Top             =   135
      Width           =   2310
   End
   Begin DriveListBox Drive1
      Height          =   315
      Left            =   3015
      TabIndex        =   3
      Top             =   1845
      Width           =   2355
   End
   Begin Label Label1
      BackStyle       =   0  'Transparent
      Caption         =   "Containing:"
      Height          =   240
      Index           =   1
      Left            =   2970
      TabIndex        =   8
      Top             =   720
      Width           =   1095
   End
   Begin Label Label1
      BackStyle       =   0  'Transparent
      Caption         =   "File Specification:"
      Height          =   240
      Index           =   0
      Left            =   2970
      TabIndex        =   7
      Top             =   225
      Width           =   1770
   End
End
Option Explicit
Option Compare Text

Dim F1 As Found
Dim CancelFlag As Integer

Sub CancelBtn_Click ()

CancelFlag = True

End Sub

Sub Drive1_Change ()

Dir1.Path = Left$(Drive1.Drive, 2)

End Sub

Function FileContains (FileName As String, SearchText As String) As Integer
Dim FileNumber As Integer
Dim FileLength As Long
Dim Chunk As String
Dim ChunkStart As Long
Const MaxChunk = 20000

On Error GoTo FileContainsError

FileNumber = FreeFile

Open FileName For Binary Access Read Shared As FileNumber
FileLength = LOF(FileNumber)
ChunkStart = 0

Do Until ChunkStart = FileLength
    If FileLength - ChunkStart > MaxChunk Then
        Chunk = Input$(MaxChunk, FileNumber)
        ChunkStart = ChunkStart + MaxChunk - Len(SearchText)
    Else
        Chunk = Input$(FileLength - ChunkStart, FileNumber)
        ChunkStart = FileLength
    End If
    If InStr(Chunk, SearchText) > 0 Then
        FileContains = True
        Exit Do
    End If
Loop

Close FileNumber

Exit Function

FileContainsError:
    Select Case Err
        Case Else
            MsgBox Error$ & " on file " & FileName
    End Select
    Exit Function

End Function

Sub Find (SearchPath As String)
ReDim DirName(0 To 15) As String
Dim DirCount As Integer
Dim FileName As String, Attributes As Integer
Dim x As Integer

If Right$(SearchPath, 1) <> "\" Then SearchPath = SearchPath & "\"
DirCount = 0
FileName = Dir$(SearchPath & FileSpec, Attr_Normal + Attr_System + Attr_Hidden)
Do Until FileName = ""
    If Containing = "" Then
        F1.FoundFiles.AddItem SearchPath & FileName
    Else
        If FileContains(SearchPath & FileName, (Containing.Text)) Then
            F1.FoundFiles.AddItem SearchPath & FileName
        End If
    End If
    FileName = Dir$
    DoEvents
    If CancelFlag Then Exit Sub
Loop

If IncludeSub Then
    FileName = Dir$(SearchPath & "*.*", Attr_Normal + Attr_System + Attr_Hidden + Attr_Directory)
    Do Until FileName = ""
        If FileName <> "." And FileName <> ".." Then
            Attributes = GetAttr(SearchPath & FileName)
            If (Attributes And Attr_Directory) Then
                If DirCount > UBound(DirName) Then
                    ReDim Preserve DirName(0 To DirCount + 15)
                End If
                DirName(DirCount) = SearchPath & FileName
                DirCount = DirCount + 1
            End If
        End If
        FileName = Dir$
        DoEvents
        If CancelFlag Then Exit Sub
    Loop
    For x = 0 To DirCount - 1
        Find DirName(x)
    Next x
End If

End Sub

Sub Form_Unload (Cancel As Integer)

If Forms.Count > 1 Then
    Select Case MsgBox("Close search windows also?", MB_YesNoCancel)
        Case IDYes
            End
        Case IDCancel
            Cancel = True
    End Select
End If

End Sub

Sub OKBtn_Click ()

'MousePointer = Hourglass
OKBtn.Enabled = False

Caption = "Find File - Searching"
CancelBtn.Visible = True

Set F1 = New Found
CancelFlag = False

If FileSpec = "" Then FileSpec = "*.*"
Find (Dir1.Path)

Caption = "Find File"
CancelBtn.Visible = False

If CancelFlag Then
    Unload F1
Else
    Select Case F1.FoundFiles.ListCount
        Case 0
            MsgBox "No files matching the search criteria were found."
            Unload F1
        Case 1
            F1.Caption = F1.FoundFiles.ListCount & " File Found"
            F1.Show
        Case Else
            F1.Caption = F1.FoundFiles.ListCount & " Files Found"
            F1.Show
    End Select
End If

OKBtn.Enabled = True
'MousePointer = Default

End Sub