请问如何用vb遍历一个文件夹下的所有文件包括自文件夹?
请问如何用vb遍历一个文件夹下的所有文件包括自文件夹?
[解决办法]
'獲取某目錄下的所有子目錄路徑及名稱和檔的路徑及名稱
Public Sub SeachFile(ByVal strPath As String)
On Error Resume Next
Dim Fso As Object
Dim Fol As Object
Dim Fil As Object
Dim DisFileName As String
Set Fso = CreateObject( "Scripting.FileSystemObject ")
Set Fol = Fso.GetFolder(strPath)
Const DeleteReadOnly = True
If strPath <> " " Then
If Right(strPath, 1) = "\ " Then
strPath = Left(strPath, Len(strPath) - 1)
End If
Label1.Caption = strPath
End If
'掃描子目錄
For Each Fol In Fol.SubFolders
SeachFile Fol
Next
End Sub
[解决办法]
可以用DIR函数,
[解决办法]
要 "弟龟 "..........................
[解决办法]
我API和DIR都写了，楼住参考一下吧
Option Explicit
'**********************************************************************************************************************
'搜索API函数、常量、类型等声明
Private Const INVALID_HANDLE_VALUE = -1
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 FindFirstFile Lib "kernel32 " Alias "FindFirstFileA " (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private WFD As WIN32_FIND_DATA
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Const MaxLFNPath = 260
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 * MaxLFNPath
cShortFileName As String * 14
End Type
'**********************************************************************************************************************
'使LISTBOX滚动条自动下拉等函数及常量声明
Public Declare Function SendMessage Lib "user32 " Alias "SendMessageA " (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_VSCROLL = &H115
Private Const SB_BOTTOM = 7
'**********************************************************************************************************************
'发送模拟按键消息
Public Declare Function PostMessage Lib "user32 " Alias "PostMessageA " (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const BM_CLICK = 245
Public Declare Function MessageBox Lib "user32 " Alias "MessageBoxA " (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
'**********************************************************************************************************************
'isPause标识是不是处于暂停中,isSearch标识是不是处于文件搜索中,isStop是否处于停止状态
Public isPause As Boolean, isSearch As Boolean, isStop As Boolean
'搜索指定路径并且包括子路径
Public Sub SearcherUserApi(ByVal strCurPath As String, Optional ByVal isCheckSub As Boolean = True)
Static sum As Long
If Right(strCurPath, 1) <> "\ " Then strCurPath = strCurPath & "\ "
Dim dirs As Long, dirbuf() As String, i As Integer, hItem As Long, k As Long, strTmp As String
hItem = FindFirstFile(strCurPath & "*.* ", WFD)
If hItem <> INVALID_HANDLE_VALUE Then
Do
If isStop Then Exit Do
sum = sum + 1
If sum Mod 20 = 0 Then DoEvents
'检查是不是目录
If (WFD.dwFileAttributes And vbDirectory) Then
' 检查是不是 ". " or ".. "
If Asc(WFD.cFileName) <> 46 Then
ReDim Preserve dirbuf(0 To dirs)
dirbuf(dirs) = Left(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
dirs = dirs + 1
strTmp = strCurPath & Left(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
frmMain.lstFolders.AddItem strTmp
SendMessage frmMain.lstFolders.hWnd, WM_VSCROLL, SB_BOTTOM, 0&
End If
Else
strTmp = strCurPath & Left(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
frmMain.lstFiles.AddItem strTmp
SendMessage frmMain.lstFiles.hWnd, WM_VSCROLL, SB_BOTTOM, 0&
End If
Loop While FindNextFile(hItem, WFD)
Call FindClose(hItem)
End If
If Not isCheckSub Then Exit Sub
For i = 0 To dirs - 1
If isStop Then Exit For
SearcherUserApi strCurPath & dirbuf(i) & "\ "
Next i
End Sub
Public Sub SeacherUserDir(ByVal strPath As String, Optional ByVal isCheckSub As Boolean = True)
Static sum As Long
Dim strFolders() As String, dirs As Integer, i As Integer
If Right(strPath, 1) <> "\ " Then strPath = strPath & "\ "
Dim strTmp As String
On Error Resume Next
strTmp = Dir(strPath & "*.* ", 1 Or 2 Or 4 Or vbDirectory)
Do While strTmp <> " "
If isStop Then Exit Do
sum = sum + 1
If sum Mod 20 = 0 Then DoEvents
If GetAttr(strPath & strTmp) And vbDirectory Then
If Left(strTmp, 1) <> ". " Then
frmMain.lstFolders.AddItem strPath & strTmp
SendMessage frmMain.lstFolders.hWnd, WM_VSCROLL, SB_BOTTOM, 0&
ReDim Preserve strFolders(0 To dirs)
strFolders(dirs) = strPath & strTmp & "\ "
dirs = dirs + 1
End If
Else
frmMain.lstFiles.AddItem strPath & strTmp
SendMessage frmMain.lstFiles.hWnd, WM_VSCROLL, SB_BOTTOM, 0&
End If
strTmp = Dir
Loop
If Not isCheckSub Then Exit Sub
For i = 0 To dirs - 1
If isStop Then Exit For
SeacherUserDir strFolders(i), isCheckSub
Next
End Sub
Public Sub RestorePublic()
isStop = False
isPause = False
isSearch = False
End Sub
