📄 文件搜索器.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 5640
ClientLeft = 60
ClientTop = 345
ClientWidth = 7995
LinkTopic = "Form1"
ScaleHeight = 5640
ScaleWidth = 7995
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton Command4
Caption = "退出"
Height = 330
Left = 6390
TabIndex = 11
Top = 315
Width = 1050
End
Begin VB.PictureBox Picture1
BackColor = &H00FFFFFF&
Height = 2985
Left = 45
ScaleHeight = 2925
ScaleWidth = 2745
TabIndex = 9
Top = 2340
Width = 2805
Begin VB.Image Image1
Height = 2850
Left = 45
Top = 45
Visible = 0 'False
Width = 2670
End
Begin VB.Label Label1
BackColor = &H00FFFFFF&
Caption = "预览区"
BeginProperty Font
Name = "宋体"
Size = 14.25
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 330
Left = 720
TabIndex = 10
Top = 1035
Width = 915
End
End
Begin VB.Frame Frame3
Caption = "搜索类型/文件"
Height = 1320
Left = 45
TabIndex = 5
Top = 945
Width = 2805
Begin VB.CommandButton Command3
Caption = "停止"
Enabled = 0 'False
Height = 285
Left = 1800
TabIndex = 8
Top = 810
Width = 825
End
Begin VB.CommandButton Command2
Caption = "搜索"
Height = 285
Left = 810
TabIndex = 7
Top = 810
Width = 825
End
Begin VB.ComboBox Combo2
Height = 300
Left = 180
TabIndex = 6
Text = "Combo2"
Top = 315
Width = 1815
End
End
Begin MSComctlLib.StatusBar StatusBar1
Align = 2 'Align Bottom
Height = 285
Left = 0
TabIndex = 4
Top = 5355
Width = 7995
_ExtentX = 14102
_ExtentY = 503
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 2
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
EndProperty
BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 1
Object.Width = 11033
EndProperty
EndProperty
End
Begin MSComctlLib.ListView ListView1
Height = 4470
Left = 2925
TabIndex = 3
Top = 855
Width = 5010
_ExtentX = 8837
_ExtentY = 7885
MultiSelect = -1 'True
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
Begin VB.Frame Frame1
Caption = "搜索路径"
Height = 690
Left = 45
TabIndex = 0
Top = 90
Width = 5685
Begin VB.CommandButton Command1
Caption = "浏览"
Height = 285
Left = 4365
TabIndex = 2
Top = 270
Width = 825
End
Begin VB.TextBox Text1
Height = 285
Left = 180
TabIndex = 1
Top = 270
Width = 3795
End
End
Begin VB.Menu popMenu
Caption = "popMenu"
Visible = 0 'False
Begin VB.Menu mnuCopy
Caption = "复制到..."
End
Begin VB.Menu mnuSelectAll
Caption = "全选"
End
Begin VB.Menu mnuRevSelect
Caption = "反向选择"
End
Begin VB.Menu mnuSelectNone
Caption = "取消选择"
End
Begin VB.Menu mm
Caption = "-"
End
Begin VB.Menu mnuDel
Caption = "删除"
End
Begin VB.Menu mnuRename
Caption = "重命名"
End
Begin VB.Menu mnuAttr
Caption = "属性"
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function SHGetPathFromIDList Lib "Shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "Shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Type BROWSEINFO '用于选择目录对话框的结构
hOwer As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
ilmage As Long
End Type
Private Const BIF_RETURNONLYFSDIRS = 0 '此常数的值待查
Private lindex As Long
Private Pflag As Boolean
'以下为显示文件属性对话框时用到的声明
Private Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
' Optional fields
lpIDList As Long
lpClass As String
hkeyClass As Long
dwHotKey As Long
hIcon As Long
hProcess As Long
End Type
Private Const SEE_MASK_INVOKEIDLIST = &HC
Private Const SEE_MASK_NOCLOSEPROCESS = &H40
Private Const SEE_MASK_FLAG_NO_UI = &H400
Private SEI As SHELLEXECUTEINFO
Private Declare Function ShellExecuteEX Lib "Shell32.dll" Alias "ShellExecuteEx" (SEI As SHELLEXECUTEINFO) As Long
Private Sub Command1_Click()
Dim bi As BROWSEINFO
Dim rtn As String, pidl As String, path As String
Dim pos As Long
bi.hOwer = Me.hwnd
bi.lpszTitle = "请选择目录" '选择目录对话框
bi.ulFlags = BIF_RETURNONLYFSDIRS
pidl = SHBrowseForFolder(bi)
path = Space(512)
SHGetPathFromIDList pidl, path
pos = InStr(path, Chr(0))
rtn = Left(path, pos - 1)
If rtn = "" Then Exit Sub
If Right(rtn, 1) <> "\" Then rtn = rtn & "\"
Text1.Text = rtn
End Sub
Private Sub Command2_Click()
Dim fso As New FileSystemObject
Dim fd As Folder
On Error Resume Next
Pflag = False
Command3.Enabled = True
ListView1.ListItems.Clear
lindex = 1
Set fd = fso.GetFolder(Text1.Text)
Command2.Enabled = False
Screen.MousePointer = vbHourglass
StatusBar1.Panels(1).Text = "请稍侯..."
FindFile fd, Combo2.Text '调用搜索过程
Command2.Enabled = True
Command3.Enabled = False
Screen.MousePointer = 0
StatusBar1.Panels(2).Text = "共有" & ListView1.ListItems.Count & "个文件"
StatusBar1.Panels(1).Text = "就绪"
End Sub
Private Sub FindFile(fd As Folder, Fname As String)
Dim sfd As Folder
Dim f As File
On Error Resume Next
StatusBar1.Panels(2).Text = "正在搜索 " & fd.path
For Each f In fd.Files '遍历文件
If UCase(f.Name) Like UCase(Fname) Then
'添加一列表项
ListView1.ListItems.Add lindex, , f.Name
'添加四个子项
ListView1.ListItems(lindex).SubItems(1) = f.ParentFolder
ListView1.ListItems(lindex).SubItems(2) = Format(f.Size / 1024, "######### KB")
ListView1.ListItems(lindex).SubItems(3) = f.Type
ListView1.ListItems(lindex).SubItems(4) = f.DateLastModified
lindex = lindex + 1
End If
DoEvents
If Pflag Then Exit Sub
Next
For Each sfd In fd.SubFolders '遍历文件夹
FindFile sfd, Fname
If Pflag Then Exit Sub
Next
End Sub
Private Sub Command3_Click()
Pflag = True
End Sub
Private Sub Command4_Click()
End
End Sub
Private Sub Form_Load()
ListView1.View = lvwReport
ListView1.ColumnHeaders.Add , , "文件名称"
ListView1.ColumnHeaders.Add , , "所在文件夹"
ListView1.ColumnHeaders.Add , , "大小"
ListView1.ColumnHeaders.Add , , "类型"
ListView1.ColumnHeaders.Add , , "修改日期"
ListView1.ColumnHeaders(2).Width = 3200
Combo2.AddItem "*.mp3"
Combo2.AddItem "*.wav"
Combo2.AddItem "*.mid"
Combo2.AddItem "*.gif"
Combo2.AddItem "*.avi"
Combo2.AddItem "*.swf"
Combo2.AddItem "*.jpg"
Combo2.AddItem "*.cur"
Combo2.AddItem "*.ico"
Combo2.Text = ""
Combo2.ListIndex = 0
End Sub
Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
Dim Fpath As String
On Error Resume Next
Image1.Stretch = False
Image1.Picture = LoadPicture(GPath(ListView1.SelectedItem.Index) & ListView1.SelectedItem.Text)
If Image1.Picture <> 0 Then
Label1.Visible = False
If Image1.Width > Picture1.ScaleWidth Then
Image1.Stretch = True
Image1.Width = Picture1.ScaleWidth
Image1.Left = 0
Else
Image1.Left = (Picture1.ScaleWidth - Image1.Width) / 2
End If
If Image1.Height > Picture1.ScaleHeight Then
Image1.Stretch = True
Image1.Height = Picture1.ScaleHeight
Image1.Top = 0
Else
Image1.Top = (Picture1.ScaleHeight - Image1.Height) / 2
End If
Image1.Visible = True
End If
End Sub
Private Sub ListView1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 2 Then
PopupMenu popMenu
End If
End Sub
Private Sub mnuAttr_Click() '显示文件属性对话框
On Error Resume Next
With SEI
.cbSize = Len(SEI)
.fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
.hwnd = Form1.hwnd
.lpVerb = "properties"
.lpFile = GPath(ListView1.SelectedItem.Index) & ListView1.SelectedItem.Text
.lpDirectory = vbNullChar
.lpParameters = vbNullChar
.nShow = 0
.hInstApp = 0
.lpIDList = 0
.lpClass = vbNullChar
.hkeyClass = 0
.dwHotKey = 0
.hProcess = 0
.hIcon = 0
End With
ShellExecuteEX SEI
End Sub
Private Sub mnuCopy_Click()
Dim bi As BROWSEINFO
Dim rtn As String, pidl As String, path As String
Dim pos As Long
Dim fso As New FileSystemObject
Dim i As Long
bi.hOwer = Me.hwnd
bi.lpszTitle = "请选择目标文件夹"
bi.ulFlags = BIF_RETURNONLYFSDIRS
pidl = SHBrowseForFolder(bi)
path = Space(512)
SHGetPathFromIDList pidl, path
pos = InStr(path, Chr(0))
rtn = Left(path, pos - 1)
If rtn <> "" Then Exit Sub
If Right(rtn, 1) <> "\" Then rtn = rtn & "\"
For i = 1 To ListView1.ListItems.Count
If ListView1.ListItems(i).Selected Then
fso.CopyFile GPath(i) & ListView1.ListItems(i).Text, rtn, True
End If
Next i
End Sub
Private Function GPath(i As Long)
GPath = IIf(Len(ListView1.ListItems(i).SubItems(1)) > 3, ListView1.ListItems(i).SubItems(1) & "\", ListView1.SelectedItem.SubItems(1))
End Function
Private Sub mnuDel_Click()
Dim fso As New FileSystemObject
Dim i As Long
Dim listCount As Long
For i = 1 To ListView1.ListItems.Count
If ListView1.ListItems(i).Selected Then
fso.DeleteFile GPath(i) & ListView1.ListItems(i).Text
End If
Next i
listCount = ListView1.ListItems.Count
Do While listCount > 0
If ListView1.ListItems(listCount).Selected Then
ListView1.ListItems.Remove listCount
End If
listCount = listCount - 1
Loop
End Sub
Private Sub mnuRename_Click()
Dim tmp As String
tmp = InputBox("将文件名改为：", "文件改名", ListView1.SelectedItem.Text)
On Error GoTo err
Name GPath(ListView1.SelectedItem.Index) & ListView1.SelectedItem.Text As GPath(ListView1.SelectedItem.Index) & tmp
ListView1.SelectedItem.Text = tmp
err:
End Sub
Private Sub mnuRevSelect_Click()
Dim i As Long
For i = 1 To ListView1.ListItems.Count
ListView1.ListItems(i).Selected = Not ListView1.ListItems(i).Selected
Next
End Sub
Private Sub mnuSelectAll_Click()
Dim i As Long
For i = 1 To ListView1.ListItems.Count
ListView1.ListItems(i).Selected = True
Next i
End Sub
Private Sub mnuSelectNone_Click()
Dim i As Long
For i = 1 To ListView1.ListItems.Count
ListView1.ListItems(i).Selected = False
Next
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -