类似windows的搜索程序，50分等你拿

如果是类似Windows中的查找文件的程序，最关键的是遍历某个文件夹。这个问题CSDN已经有人解决了。我的思路是引用FSO。其实象这种问题要别人写好代码是不行的。

API声明
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 = &H1 '此常数的值待查
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
'以下为利用API查找文件的声明
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const MAX_PATH = 260
Private Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
        dwFileAttributes As Long
        ftCreationTime As FILETIME
        ftLastAccessTime As FILETIME
        ftLastWriteTime As FILETIME
        nFileSizeHigh As Long
        nFileSizeLow As Long
        dwReserved0 As Long
        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 SubPrivate 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 SubPrivate Sub Command3_Click()
    Pflag = True
End SubPrivate Sub Command4_Click()
    End
End SubPrivate 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 "*.exe"
    Combo2.AddItem "*.mp3"
    Combo2.AddItem "*.wav"
    Combo2.AddItem "*.mid"
    Combo2.AddItem "*.gif"
    Combo2.AddItem "*.avi"
    Combo2.AddItem "*.rm"
    Combo2.AddItem "*.swf"
    Combo2.AddItem "*.jpg"
    Combo2.AddItem "*.cur"
    Combo2.AddItem "*.ico"
    Combo2.Text = ""
    Combo2.ListIndex = 0
End SubPrivate 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 SubPrivate 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 SubPrivate 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 FunctionPrivate 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 SubPrivate 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 SubPrivate 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 SubPrivate Sub mnuSelectAll_Click()
    Dim i As Long
    For i = 1 To ListView1.ListItems.Count
        ListView1.ListItems(i).Selected = True
    Next i
End SubPrivate Sub mnuSelectNone_Click()
    Dim i As Long
    For i = 1 To ListView1.ListItems.Count
        ListView1.ListItems(i).Selected = False
    Next
End Sub

调试易

类似windows的搜索程序，50分等你拿

解决方案 »