home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
On Hand
/
On_Hand_From_Softbank_1994_Release_2_Disc_2_1994.iso
/
00202
/
s
/
disk1
/
seek.fr_
/
seek.bin
Wrap
Text File
|
1993-04-28
|
9KB
|
281 lines
VERSION 2.00
Begin Form WinSeek
BackColor = &H00C0C0C0&
BorderStyle = 3 'Fixed Double
Caption = "Seek"
ForeColor = &H00000080&
Height = 4440
Left = 2190
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4035
ScaleWidth = 3690
Top = 1575
Width = 3810
Begin PictureBox Picture2
BorderStyle = 0 'None
Height = 2895
Left = 720
ScaleHeight = 2895
ScaleWidth = 3855
TabIndex = 8
Top = 1080
Visible = 0 'False
Width = 3855
Begin ListBox lstFoundFiles
Height = 2370
Left = 120
TabIndex = 11
Top = 480
Width = 3375
End
Begin Label lblCount
Caption = "0"
Height = 255
Left = 1200
TabIndex = 10
Top = 120
Width = 1095
End
Begin Label lblfound
Caption = "&Files Found:"
Height = 255
Left = 120
TabIndex = 9
Top = 120
Width = 1095
End
End
Begin PictureBox Picture1
BorderStyle = 0 'None
Height = 2895
Left = 0
ScaleHeight = 2895
ScaleWidth = 3735
TabIndex = 2
Top = 120
Width = 3735
Begin DriveListBox drvList
Height = 1530
Left = 2040
TabIndex = 7
Top = 480
Width = 1575
End
Begin DirListBox dirList
Height = 1695
Left = 2040
TabIndex = 6
Top = 960
Width = 1575
End
Begin FileListBox filList
Height = 2175
Left = 120
TabIndex = 5
Top = 480
Width = 1815
End
Begin TextBox txtSearchSpec
Height = 285
Left = 2040
TabIndex = 4
Text = "*.*"
Top = 120
Width = 1575
End
Begin Label lblCriteria
Caption = "Search &Criteria:"
Height = 255
Left = 600
TabIndex = 3
Top = 120
Width = 1335
End
End
Begin CommandButton cmdSearch
BackColor = &H00C0C0C0&
Caption = "&Search"
Default = -1 'True
Height = 720
Left = 480
TabIndex = 0
Top = 3000
Width = 1200
End
Begin CommandButton cmdExit
BackColor = &H00C0C0C0&
Caption = "E&xit"
Height = 720
Left = 2040
TabIndex = 1
Top = 3000
Width = 1200
End
End
Option Explicit
Dim SearchFlag As Integer ' Used as flag for cancelling, etc.
Sub cmdExit_Click ()
If cmdExit.Caption = "E&xit" Then
End
Else ' If Cancel, just end Search.
SearchFlag = False
End If
End Sub
Sub cmdSearch_Click ()
' Initialize for search, then call DirDiver to perform recursive search.
Dim FirstPath As String, DirCount As Integer, NumFiles As Integer
Dim result As Integer
' Check what the user did last:
If cmdSearch.Caption = "&Reset" Then ' If just a reset,
ResetSearch ' initialize and exit.
txtSearchSpec.SetFocus
Exit Sub
End If
' Update dirList.Path if it is different from the currently
' selected directory, otherwise perform the search.
If dirList.Path <> dirList.List(dirList.ListIndex) Then
dirList.Path = dirList.List(dirList.ListIndex)
Exit Sub ' Exit so user can take a look before searching.
End If
' Continue with the search.
Picture2.Move 0, 0
Picture1.Visible = False
Picture2.Visible = True
cmdExit.Caption = "Cancel"
filList.Pattern = txtSearchSpec.Text
FirstPath = dirList.Path
DirCount = dirList.ListCount
'Start recursive direcory search.
NumFiles = 0 ' Reset global foundfiles indicator.
result = DirDiver(FirstPath, DirCount, "")
filList.Path = dirList.Path
cmdSearch.Caption = "&Reset"
cmdSearch.SetFocus
cmdExit.Caption = "E&xit"
End Sub
Function DirDiver (NewPath As String, DirCount As Integer, BackUp As String) As Integer
' Recursively search directories from NewPath down...
' NewPath is searched on this recursion.
' BackUp is origin of this recursion.
' DirCount is number of subdirectories in this directory.
Static FirstErr As Integer
Dim DirsToPeek As Integer, AbandonSearch As Integer, ind As Integer
Dim OldPath As String, ThePath As String, entry As String
Dim retval As Integer
SearchFlag = True ' Set flag so user can interrupt.
DirDiver = False ' Set to TRUE if there is an error.
retval = DoEvents() ' check for events (i.e. user Cancels).
If SearchFlag = False Then
DirDiver = True
Exit Function
End If
On Local Error GoTo DirDriverHandler
DirsToPeek = dirList.ListCount ' How many directories below this?
Do While DirsToPeek > 0 And SearchFlag = True
OldPath = dirList.Path ' Save old path for next recursion.
dirList.Path = NewPath
If dirList.ListCount > 0 Then
' Get to the node bottom.
dirList.Path = dirList.List(DirsToPeek - 1)
AbandonSearch = DirDiver((dirList.Path), DirCount%, OldPath)
End If
' Go up 1 level in directories.
DirsToPeek = DirsToPeek - 1
If AbandonSearch = True Then Exit Function
Loop
' Call function to enumerate files.
If filList.ListCount Then
If Len(dirList.Path) <= 3 Then
ThePath = dirList.Path ' If at root level, leave as is...
Else
ThePath = dirList.Path + "\" ' otherwise put "\" before file name.
End If
For ind = 0 To filList.ListCount - 1 ' Add conforming files in
entry = ThePath + filList.List(ind) ' this directory to listbox.
lstFoundFiles.AddItem entry
lblCount.Caption = Str$(Val(lblCount.Caption) + 1)
Next ind
End If
If BackUp <> "" Then ' If there is a superior
dirList.Path = BackUp ' directory, move to it.
End If
Exit Function
DirDriverHandler:
If Err = 7 Then ' If Out of Memory, assume listbox just got full.
DirDiver = True ' Create Msg$ and set return value AbandonSearch.
MsgBox "You've filled the listbox. Search being abandoned..."
Exit Function ' Note that EXIT procedure resets ERR to 0.
Else ' Otherwise display error message and quit.
MsgBox Error
End
End If
End Function
Sub DirList_Change ()
' Update File listbox to sync with Dir listbox.
filList.Path = dirList.Path
End Sub
Sub DirList_LostFocus ()
dirList.Path = dirList.List(dirList.ListIndex)
End Sub
Sub DrvList_Change ()
On Error GoTo DriveHandler
dirList.Path = drvList.Drive
Exit Sub
DriveHandler:
drvList.Drive = dirList.Path
Exit Sub
End Sub
Sub Form_Load ()
Picture2.Move 0, 0
Picture2.Width = WinSeek.ScaleWidth
Picture2.BackColor = WinSeek.BackColor
lblCount.BackColor = WinSeek.BackColor
lblCriteria.BackColor = WinSeek.BackColor
lblFound.BackColor = WinSeek.BackColor
Picture1.Move 0, 0
Picture1.Width = WinSeek.ScaleWidth
Picture1.BackColor = WinSeek.BackColor
End Sub
Sub Form_Unload (Cancel As Integer)
End
End Sub
Sub ResetSearch ()
' Reinitialize before starting a new search.
lstFoundFiles.Clear
lblCount.Caption = 0
SearchFlag = False ' Flag indicating search in progress.
Picture2.Visible = False
cmdSearch.Caption = "&Search"
cmdExit.Caption = "E&xit"
Picture1.Visible = True
dirList.Path = CurDir$: drvList.Drive = dirList.Path ' Reset DOS path.
End Sub
Sub txtSearchSpec_Change ()
' Update file list box if user changes pattern.
filList.Pattern = txtSearchSpec.Text
End Sub
Sub txtSearchSpec_GotFocus ()
txtSearchSpec.SelStart = 0 ' Highlight the current entry.
txtSearchSpec.SelLength = Len(txtSearchSpec.Text)
End Sub