文件搜索器(api).frm

个人VB学习源码精选,自己学习时的一些编程小程序,希望对大家有帮助

        dwReserved1 As Long
        cFileName As String * MAX_PATH
        cAlternate As String * 14
End Type


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
    Text1.Text = rtn
End Sub

Private Sub Command2_Click()
    Dim fso As New FileSystemObject
    On Error Resume Next
    Pflag = False
    Command3.Enabled = True
    ListView1.ListItems.Clear
    lindex = 1
    Command2.Enabled = False
    Screen.MousePointer = vbHourglass
    StatusBar1.Panels(1).Text = "请稍侯..."
    FindFile Trim(Text1.Text), Trim(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(sPath As String, sFile As String)
    Dim xf As WIN32_FIND_DATA
    Dim ff As WIN32_FIND_DATA
    Dim findhandle As Long
    Dim lFindFile As Long
    Dim Dstr As String
    Dim fso As New FileSystemObject
    Dim f As File
    Dim cPath As String
    
    On Error Resume Next
    cPath = IIf(Len(sPath) > 3, sPath & "\", sPath)
    lFindFile = FindFirstFile(cPath & sFile, ff)
    StatusBar1.Panels(2).Text = "正在搜索 " & sPath
    If lFindFile > 0 Then
        Do
            Set f = fso.GetFile(cPath & ff.cFileName)
            ListView1.ListItems.Add lindex, , f.Name
            ListView1.ListItems(lindex).SubItems(1) = f.ParentFolder
            ListView1.ListItems(lindex).SubItems(2) = IIf(f.Size < 1024, Format(f.Size, "#### Byte"), Format(f.Size \ 1024, "###### KB"))
            ListView1.ListItems(lindex).SubItems(3) = f.Type
            ListView1.ListItems(lindex).SubItems(4) = Left(f.DateLastModified, Len(CStr(f.DateLastModified)) - 3)
            lindex = lindex + 1
        Loop Until (FindNextFile(lFindFile, ff) = 0)
        FindClose lFindFile
        If Pflag Then Exit Sub
    End If
    findhandle = FindFirstFile(cPath & "*.*", xf)
    DoEvents
    Do  '注意这处判断是否为目录应使用与运算
        If (xf.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
            If Asc(xf.cFileName) <> Asc(".") Then
                Dstr = cPath + Left(xf.cFileName, InStr(xf.cFileName, Chr(0)) - 1)
                FindFile Dstr, sFile
            End If
        End If
        If Pflag Then
            FindClose findhandle
            Exit Sub
        End If
    Loop Until (FindNextFile(findhandle, xf) = 0)
    FindClose findhandle
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