- 小教板
-
VB搜索文件夹,列出指定文件夹下全部文件夹或全部隐藏的文件夹
"查找第一个文件的API
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
"查找下一个文件的API
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
"获取文件属性的API
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
"关闭查找文件的API
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
"常量
Private Const MAX_PATH = 260
Private Const MAXDWORD = &HFFFF
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const BIF_RETURNONLYFSDIRS = 1
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
Function GetAllFilePath(path As String, SearchStr As String, bOnlyHidden As Boolean)
Dim FileName As String " 文件名
Dim DirName As String " 子目录名
Dim dirNames() As String " 目录数组
Dim nDir As Integer " 当前路径的目录数
Dim i As Integer " 循环计数器变量
Dim hSearch As Long " 搜索句柄变量
Dim WFD As WIN32_FIND_DATA
Dim Cont As Integer
Dim FileAttrib As Long
If Right(path, 1) <> "" Then path = path & ""
"搜索子目录
nDir = 0
ReDim dirNames(nDir)
Cont = True
hSearch = FindFirstFile(path & "*", WFD)
If hSearch <> INVALID_HANDLE_VALUE Then
Do While Cont
DirName = StripNulls(WFD.cFileName)
If (DirName <> ".") And (DirName <> "..") Then
FileAttrib = GetFileAttributes(path & DirName)
If FileAttrib And FILE_ATTRIBUTE_DIRECTORY Then
If bOnlyHidden Then
If FileAttrib And FILE_ATTRIBUTE_HIDDEN Then List1.AddItem path & DirName
Else
List1.AddItem path & DirName
End If
End If
dirNames(nDir) = DirName
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
End If
Cont = FindNextFile(hSearch, WFD) "获取下一个子目录
Loop
Cont = FindClose(hSearch)
End If
" 遍历目录并累计文件总数
hSearch = FindFirstFile(path & SearchStr, WFD)
Cont = True
If hSearch <> INVALID_HANDLE_VALUE Then
While Cont
FileName = StripNulls(WFD.cFileName)
If (FileName <> ".") And (FileName <> "..") Then
GetAllFilePath = GetAllFilePath + (WFD.nFileSizeHigh * MAXDWORD) + WFD.nFileSizeLow
End If
Cont = FindNextFile(hSearch, WFD) " 获取下一个文件
Wend
Cont = FindClose(hSearch)
End If
"如果子目录存在则遍历之
If nDir > 0 Then
For i = 0 To nDir - 1
GetAllFilePath = GetAllFilePath + GetAllFilePath(path & dirNames(i) & "", SearchStr, bOnlyHidden)
Next i
End If
End Function
Function StripNulls(OriginalStr As String) As String
If (InStr(OriginalStr, Chr(0)) > 0) Then
OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
End If
StripNulls = OriginalStr
End Function
Private Sub Command1_Click()
Dim SearchPath As String
Dim FindStr As String
List1.Clear
SearchPath = "c: ootdir"
FindStr = "*.*"
GetAllFilePath SearchPath, FindStr, true
End Sub
调用方法
GetAllFilePath SearchPath, FindStr, bOnlyHidden
SearchPath 起始路径
FindStr 要查找文件夹名称
bOnlyHidden 是否只查找隐藏的, true 只查找隐藏文件夹, false 全部文件夹
- 真可
-
Option Explicit
Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const DT_NOPREFIX As Long = 2048
Private Const DT_PATH_ELLIPSIS As Long = &H4000
Private Const DT_WORDBREAK As Long = &H10
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
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 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 Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function DrawText Lib "USER32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private m_bCancel As Boolean
Private m_sFind As String
Private m_lFilesFound As Long
Private m_DestinationFile As String
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED = 3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM = 5
Private Const DRIVE_RAMDISK = 6
Private Sub Form_Load()
Command1.Caption = "开始搜索文件..."
Command2.Caption = "停止搜索"
End Sub
Private Sub Command1_Click()
Dim mPath As String
Dim v As Long
If Trim(Text1.Text) = "" Then Exit Sub
mPath = Trim(Text1.Text) "要搜索的驱动器/目录
If Right(mPath, 1) <> "" Then
mPath = mPath & ""
End If
m_sFind = "*.Txt" "指定要搜索的文件类型可以设置(*.*),如果要搜索多种类型,就要用Split函数处理成数组。
m_bCancel = False
List1.Clear "如果不用ListBox显示结果,速度还会快一点。
If Trim(Text2.Text) = "" Then Exit Sub
m_DestinationFile = Trim(Text2.Text) "要拷贝的目标驱动器/目录
If Right(m_DestinationFile, 1) <> "" Then
m_DestinationFile = m_DestinationFile & ""
End If
m_lFilesFound = 0
v = GetDriveType(m_DestinationFile)
Select Case v
Case 0 "不能识别的驱动器
MsgBox "不能识别指定要复制文件的目标驱动器!", vbCritical, "提示"
Case 1 "指定的目录不存
MsgBox "指定要复制文件的目标路径不正确!", vbCritical, "提示"
Case DRIVE_REMOVABLE
Case DRIVE_FIXED
Call SearchFolders(mPath)
Case DRIVE_REMOTE
Case DRIVE_CDROM
MsgBox "不能向光盘驱动器拷贝文件!", vbCritical, "提示"
Case DRIVE_RAMDISK
End Select
Call UpdateStatus("搜索符合(" & m_sFind & ")条的文件共:" & CStr(m_lFilesFound) & " 个")
End Sub
Private Sub Command2_Click()
m_bCancel = True "停止搜索
End Sub
Private Sub SearchFolders(ByRef sFolder As String)
Dim hFind As Long
Dim uFind As WIN32_FIND_DATA
Dim lFiles As Long
hFind = FindFirstFile(sFolder & "*.*", uFind)
If hFind <> INVALID_HANDLE_VALUE Then
UpdateStatus "Searching -> " & sFolder "显示搜索状态
DoEvents
If Not m_bCancel Then
lFiles = SearchFiles(sFolder)
Do
If uFind.dwFileAttributes And vbDirectory Then
If AscW(uFind.cFileName) <> 46 Then
SearchFolders sFolder & Left$(uFind.cFileName, InStr(uFind.cFileName, vbNullChar) - 1) & ""
End If
End If
Loop Until FindNextFile(hFind, uFind) = 0
End If
FindClose hFind
End If
End Sub
Private Function SearchFiles(ByRef sFolder As String) As Long
Dim hFind As Long
Dim uFind As WIN32_FIND_DATA
Dim sFile As String
Dim uLocalTime As FILETIME
Dim uSysTime As SYSTEMTIME
Dim dtDate As Date
hFind = FindFirstFile(sFolder & m_sFind, uFind)
If hFind <> INVALID_HANDLE_VALUE Then
Do
If Not (uFind.dwFileAttributes And vbDirectory) Or (AscW(uFind.cFileName) = 46) Then
sFile = Left$(uFind.cFileName, InStr(uFind.cFileName, vbNullChar) - 1)
FileTimeToLocalFileTime uFind.ftLastWriteTime, uLocalTime
If FileTimeToSystemTime(uLocalTime, uSysTime) = 0 Then
List1.AddItem sFile
Else
With uSysTime "获取文件修改时间
dtDate = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond)
End With
"显示搜索内容
List1.AddItem sFolder & sFile "& vbTab & CStr(dtDate)
Call FileCopy(sFolder & sFile, m_DestinationFile & sFile) "拷贝文件
End If
m_lFilesFound = m_lFilesFound + 1
End If
Loop Until FindNextFile(hFind, uFind) = 0
FindClose hFind
End If
End Function
Private Sub UpdateStatus(ByRef sStatus As String)
Dim uRect As RECT
Picture1.Cls
If LenB(sStatus) <> 0 Then
uRect.Right = Picture1.Width - 1
uRect.Bottom = Picture1.Height - 1
DrawText Picture1.hDC, sStatus, -1, uRect, DT_PATH_ELLIPSIS Or DT_NOPREFIX Or DT_WORDBREAK
End If
End Sub
- LuckySXyd
-
Option Explicit
Dim fname$, sppath$, FolderPath$
Dim spShell, spFolder, spFolderItem, sfolder, folderitem, subf, subitem
Private Sub Command1_Click()
On Error GoTo errhandler
Set spShell = CreateObject("Shell.Application")
Set spFolder = spShell.BrowseForFolder(0, "选择目录:", 0, "")
Set spFolderItem = spFolder.Self
sppath = spFolderItem.Path
If Right(sppath, 1) <> "" Then sppath = sppath & ""
Call showalldirs
errhandler:
If Err > 0 Then Exit Sub
End Sub
Private Sub showalldirs()
List1.Clear
Dim fol, fso, fil, fils, s, f, fldr
Set fso = CreateObject("Scripting.FileSystemObject")
Set sfolder = fso.GetFolder(sppath).SubFolders
For Each folderitem In sfolder
List1.AddItem sppath & FolderPath & folderitem.Name
Set subf = fso.GetFolder(sppath & FolderPath & folderitem.Name & "").SubFolders
For Each subitem In subf
List1.AddItem sppath & FolderPath & folderitem.Name & "" & subitem.Name
Next
Next
End Sub
- ardim
-
在窗体上加入控件list1,command1,然后复制下面代码,运行即可。
Option Explicit
Dim fs, foldername
Function digui(path)
Dim folder, subfolders, j
Set folder = fs.getfolder(path)
Set subfolders = folder.subfolders
For Each j In subfolders
List1.AddItem j.path
DoEvents
digui (j.path)
Next
End Function
Private Sub Command1_Click()
foldername = InputBox("请输入起始文件夹:", "提示")
If foldername = "" Then
Exit Sub
End If
Set fs = CreateObject("scripting.filesystemobject")
digui (foldername)
End Sub
- meira
-
你是要搜索所有盘上的所有文件夹还是只搜索指定的?
我这里有搜索全盘所有内容的代码,很大,加百度HI发给你