急求vb课程设计。

’‘’‘’‘’‘’‘’‘’‘’‘实现在盘中搜索你想找的文件...
‘’‘’‘’‘’‘’‘’‘’‘form1
Option Explicit

Dim Arr()

Dim tempArr()

Dim flag As Boolean

Dim path As String

Dim allDrive As Boolean

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Dim Fs As New FileSystemObject
Private Sub cmdFileCon_Click()
ReDim Arr(0 To 2, 0 To 0)

StatusBar1.Panels(1).Width = 40000

path = dSub.path

savePath path

FG1.aaBindArr Arr

StatusBar1.Panels(1).Text = "完成" & UBound(Arr, 2) & ""

End Sub
Sub savePath(path)
On Error Resume Next

StatusBar1.Panels(1).Text = "正在查找....." & path

Dim Upfd As Folder
Dim Fd As Folder
Dim Fi As File

' For Each Upfd In Fs.GetDrive(path).RootFolder
' addArr Upfd, "文件夹"
' savePath Upfd
' Next
For Each Fd In Fs.GetFolder(path).SubFolders
addArr Fd, "文件夹"
savePath Fd
Next

For Each Fi In Fs.GetFolder(path).Files
addArr Fi, "文件"

Next

End Sub
Sub addArr(path, cla)

ReDim Preserve Arr(0 To UBound(Arr, 1), 0 To UBound(Arr, 2) + 1)

Arr(1, UBound(Arr, 2)) = cla
Arr(2, UBound(Arr, 2)) = path

End Sub

Private Sub Command1_Click()
Dim Di As Drive
ReDim Arr(0 To 2, 0 To 0)
StatusBar1.Panels(1).Width = 40000

For Each Di In Fs.Drives

savePath Di & "\"

Next

FG1.aaBindArr Arr

StatusBar1.Panels(1).Text = "完成 " & UBound(Arr, 2) & ""
End Sub
Private Sub Command2_Click()

If Combo1.Text = "指定盘符" Then
cmdFileCon_Click
Else

Command1_Click

End If

SeleArr Arr, tempArr, "*" & Text1.Text & "*", 2

FG1.Rows = 1
FG1.Refresh

FG1.AutoRedraw = True

FG1.aaBindArr tempArr
StatusBar1.Panels(1).Text = "合计" & UBound(tempArr, 2)

End Sub

Private Sub Command3_Click()
'''''''''''''打开选中的文件选项
Select Case Right(Trim(FG1.Cell(FG1.ActiveCell.row, FG1.ActiveCell.Col).Text), 3)
Case "exe"
Shell Trim(FG1.Cell(FG1.ActiveCell.row, FG1.ActiveCell.Col).Text)
Case "txt"

Shell "notepad.exe " & FG1.ActiveCell.Text, vbNormalFocus

Case Else

' Call ShellExecute(0, "open", Trim(FG1.Cell(FG1.ActiveCell.row, FG1.ActiveCell.Col).Text), vbNullString, vbNormalFocus)
'

End Select

End Sub

Private Sub drMain_Change()

dSub.path = drMain.Drive & "\"

End Sub

Private Sub dSub_Click()

path = dSub.path

End Sub

Private Sub dSub_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
path = dSub.path
End Sub

Private Sub FG1_DblClick()
'''''''''''
On Error Resume Next

Select Case Right(Trim(FG1.Cell(FG1.ActiveCell.row, FG1.ActiveCell.Col).Text), 3)
Case "exe"
Shell Trim(FG1.Cell(FG1.ActiveCell.row, FG1.ActiveCell.Col).Text)
Case "txt"

Shell "notepad.exe " & FG1.ActiveCell.Text, vbNormalFocus

Case "xls"

Shell "excel.exe " & FG1.ActiveCell.Text, vbNormalFocus
Case ""

Case Else
If Left(Right(Trim(FG1.Cell(FG1.ActiveCell.row, FG1.ActiveCell.Col).Text), 4), 1) = "." Then

End If

MsgBox "请使用专用工具打开!"
End Select

End Sub

Private Sub Form_Load()
Label1.Caption = "#双击文件夹表示选中"

Dim X As Printer

For Each X In Printers
Set Printer = X

Next

Combo1.AddItem "指定盘符"
Combo1.AddItem "全盘搜索"

End Sub

'''''''''''''''''''模块
Option Explicit

Sub SeleArr(Arr1, Arr2, Str, KeyCol _
, Optional Str1 As String = "", Optional KeyCol1 = -1 _
, Optional Str2 As String = "", Optional KeyCol2 = -1 _
, Optional Str3 As String = "", Optional KeyCol3 = -1 _
, Optional Str4 As String = "", Optional KeyCol4 = -1 _
, Optional Str5 As String = "", Optional KeyCol5 = -1)
Dim t As Long, p As Long

Dim IsIt As String

ReDim Arr2(0 To UBound(Arr1, 1), 0 To UBound(Arr1, 2))

For p = 1 To UBound(Arr1)
Arr2(p, 0) = Arr1(p, 0)
Next

Dim row As Long
For t = 1 To UBound(Arr1, 2)
IsIt = ""
If Not (Vstr(Arr1(KeyCol, t)) Like Str) Then GoTo DoDo

If KeyCol1 <> -1 Then
If Not (Vstr(Arr1(KeyCol1, t)) Like Str1) Then GoTo DoDo
End If

If KeyCol2 <> -1 Then
If Not (Vstr(Arr1(KeyCol2, t)) Like Str2) Then GoTo DoDo
End If

If KeyCol3 <> -1 Then
If Not (Vstr(Arr1(KeyCol3, t)) Like Str3) Then GoTo DoDo
End If

If KeyCol4 <> -1 Then
If Not (Vstr(Arr1(KeyCol4, t)) Like Str4) Then GoTo DoDo
End If

If KeyCol5 <> -1 Then
If Not (Vstr(Arr1(KeyCol5, t)) Like Str5) Then GoTo DoDo
End If

row = row + 1
For p = 1 To UBound(Arr1)
Arr2(p, row) = Arr1(p, t)
Next
DoDo:
Next
ReDim Preserve Arr2(0 To UBound(Arr1, 1), 0 To row)
End Sub

Function Vstr(Str, Optional ByVal Rep As String = "")
On Error GoTo 100
If IsNull(Str) Then GoTo 100
Vstr = Str & ""
Exit Function
100
Vstr = Rep
End Function

Function VValue(Str, Optional ByVal Rep = 0)
On Error GoTo 100
If IsNull(Str) Then GoTo 100
VValue = Str * 1
Exit Function
100
VValue = Rep
End Function

'