请问如何用vb遍历一个文件夹下的所有文件包括自文件夹?

#1

'獲取某目錄下的所有子目錄路徑及名稱和檔的路徑及名稱
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

#2

可以用DIR函数,

#3

要"弟龟"..........................

#4

我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

#5

Ding

————————————————————————————————————
写作，虽然每个人都会查阅辞海，可，不是人人都能写出不朽的篇章的。编程，如是也。

#6

弄个函数给你 SFolderSearch参数是要搜索的文件夹的路径
Private Sub Search(SFolderSearch As Folder)
Dim SFolder As Folder
Dim SFile As File

'搜索文件夹中的文件
   For Each SFile In SFolderSearch.Files
         '一些相关操作
   Next
'搜索文件夹中的子文件夹
   For Each SFolder In SFolderSearch.SubFolders
     Call Search(SFolder)  '递归
   Next
'可以一直搜索到最底层

End Sub

#7

'A very good reference for bkm2 (bkm2) about topic "请问如何用vb遍历一个文件夹下的所有文件包括自文件夹?" -- CHEERS!!!

Private Sub Form_Load()
On Error GoTo Hell

Dim sSearchPath As String, sExtensionList As String
Dim taFiles As mctFileSearchResults
Dim x As Long

    Me.Show
    DoEvents
    Screen.MousePointer = vbHourglass

    sSearchPath = "C:\windows\system32"
    sExtensionList = "*.*" '"*.txt;*.exe"

    FileSearchA sSearchPath, sExtensionList, taFiles, False

    If taFiles.FileCount > 0 Then
        With Listview
            .View = lvwReport
            .Move 60, 60, 10995, 3435
            With .ColumnHeaders
                .Add , , "Filename", 1560
                .Add , , "Extension", 900
                .Add , , "Path", 1904
                .Add , , "Size", 989
                .Add , , "Read-Only", 945
                .Add , , "UNC Path", 2910
                .Add , , "Creation Date", 1440
            End With
            Me.Move Me.Left, Me.Top, .Width + 240, .Height + 520
        End With

        For x = 1 To UBound(taFiles.Files)
            With Listview.ListItems.Add(, , taFiles.Files(x).FileName)
                .SubItems(1) = taFiles.Files(x).Extension
                .SubItems(2) = taFiles.Files(x).FilePath
                .SubItems(3) = FormatNumber(taFiles.Files(x).Size, 0)
                .SubItems(4) = IIf(taFiles.Files(x).ReadOnly, "Yes", "")
                .SubItems(5) = taFiles.Files(x).UNC
                .SubItems(6) = taFiles.Files(x).CreationDate
            End With
        Next
        With Listview.ListItems.Add(, , "Totals")
            .SubItems(5) = taFiles.FileCount & " Files"
            .SubItems(3) = Format$(taFiles.FileSize, "###,###,###,##0") & " Bytes"
        End With
    End If
    Screen.MousePointer = vbDefault

Exit Sub
Hell:
    Debug.Print Err.Description: Stop: Resume
End Sub

#8

'a bas file
Public Type mctFileInfoType
    FilePath As String
    FileName As String
    UNC As String
    Extension As String
    Size As Currency
    ReadOnly As Boolean
    CreationDate As String
End Type

Public Type mctFileSearchResults
    FileCount As Long
    FileSize As Currency
    Files() As mctFileInfoType
End Type

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 Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime 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 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 FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long

Private Function GetFileSize_(ByVal iFileSizeHigh As Long, ByVal iFileSizeLow As Long) As Currency

    Dim curFileSizeHigh As Currency
    Dim curFileSizeLow As Currency
    Dim curFileSize As Currency

    curFileSizeHigh = CCur(iFileSizeHigh)
    curFileSizeLow = CCur(iFileSizeLow)

    curFileSize = curFileSizeLow

    If curFileSizeLow < 0 Then
        curFileSize = curFileSize + 4294967296@
    End If

    If curFileSizeHigh > 0 Then
        curFileSize = curFileSize + (curFileSizeHigh * 4294967296@)
    End If

    GetFileSize_ = curFileSize

End Function
Public Sub FileSearchA(ByVal sPath As String, ByVal sFileMask As String, ByRef taFiles As mctFileSearchResults, _
                       Optional ByVal bRecursive As Boolean = False, Optional ByVal iRecursionLevel As Long = -1)
On Error GoTo Hell

Dim sFilename As String
Dim sFolder As String
Dim iFolderCount As Long
Dim aFolders() As String
Dim aFileMask() As String
Dim iSearchHandle As Long
Dim WFD As WIN32_FIND_DATA
Dim bContinue As Long: bContinue = True
Dim Ret As Long, x As Long
Dim tSystemTime As SYSTEMTIME

    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"

    ' Search for subdirectories first and save'em for later
    ' --------------------------
    If bRecursive Then
        iSearchHandle = FindFirstFile(sPath & "*.", WFD)

        If iSearchHandle <> INVALID_HANDLE_VALUE Then
            Do While bContinue

                If (InStr(WFD.cFileName, Chr(0)) > 0) Then WFD.cFileName = Left(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1)
                sFolder = Trim$(WFD.cFileName)

                If (sFolder <> ".") And (sFolder <> "..") Then ' Ignore the current and encompassing directories
                    If WFD.dwFileAttributes And vbDirectory Then
                        iFolderCount = iFolderCount + 1
                        ReDim Preserve aFolders(iFolderCount)
                        aFolders(iFolderCount) = sFolder
                    End If
                End If

                bContinue = FindNextFile(iSearchHandle, WFD) 'Get next subdirectory.

            Loop
            bContinue = FindClose(iSearchHandle)
        End If
    End If
    ' --------------------------

    bContinue = True

    ' Walk through this directory and sum file sizes.
    ' --------------------------

    ' FindFirstFile takes one type at a time, so we'll loop the search for as many extensions as specified
    aFileMask = Split(sFileMask, ";")
    For x = 0 To UBound(aFileMask)

        ' Make sure it's all formatted
        If Left$(aFileMask(x), 1) = "." Then
            aFileMask(x) = "*" & aFileMask(x)
        ElseIf Left$(aFileMask(x), 2) <> "*." Then
            aFileMask(x) = "*." & aFileMask(x)
        End If

        iSearchHandle = FindFirstFile(sPath & aFileMask(x), WFD)

        If iSearchHandle <> INVALID_HANDLE_VALUE Then
            Do While bContinue

                If (InStr(WFD.cFileName, Chr(0)) > 0) Then WFD.cFileName = Left(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1)
                sFilename = Trim$(WFD.cFileName)

                ' It's a file, right?
                If (sFilename <> ".") And (sFilename <> "..") And (Not (WFD.dwFileAttributes And vbDirectory) = vbDirectory) Then
                    With taFiles
                        .FileSize = .FileSize + GetFileSize_(WFD.nFileSizeHigh, WFD.nFileSizeLow)
                        .FileCount = .FileCount + 1
                        ReDim Preserve .Files(.FileCount)
                        With .Files(.FileCount)
                            .Extension = Mid$(sFilename, InStrRev(sFilename, ".") + 1)
                            .FileName = sFilename
                            .FilePath = sPath
                            .ReadOnly = (WFD.dwFileAttributes And vbReadOnly) = vbReadOnly
                            .Size = GetFileSize_(WFD.nFileSizeHigh, WFD.nFileSizeLow)
                            .UNC = sPath & sFilename
                            If FileTimeToSystemTime(WFD.ftCreationTime, tSystemTime) Then .CreationDate = tSystemTime.wMonth & "/" & tSystemTime.wDay & "/" & tSystemTime.wYear & " " & IIf(tSystemTime.wHour > 12, tSystemTime.wHour - 12 & ":" & tSystemTime.wMinute & " PM", tSystemTime.wHour & ":" & tSystemTime.wMinute & " AM")
                        End With
                    End With
                End If
                bContinue = FindNextFile(iSearchHandle, WFD) ' Get next file
            Loop
            bContinue = FindClose(iSearchHandle)
        End If
    Next
    ' --------------------------

    ' If there are sub-directories,
    If iFolderCount > 0 Then
        ' And if we care,
        If bRecursive Then
            If iRecursionLevel <> 0 Then ' Recursively walk into them...
                iRecursionLevel = iRecursionLevel - 1
                For x = 1 To iFolderCount
                    FileSearchA sPath & aFolders(x) & "\", sFileMask, taFiles, bRecursive, iRecursionLevel
                Next x
            End If
        End If
    End If

' --------------------------------------------------------------------------
Exit Sub
Hell:
    Debug.Print Err.Description: Stop: Resume
End Sub

Private Function GetFileSize_(ByVal iFileSizeHigh As Currency, ByVal iFileSizeLow As Currency) As Currency

    GetFileSize_ = iFileSizeLow
    If iFileSizeLow < 0 Then GetFileSize_ = GetFileSize_ + 4294967296@
    If iFileSizeHigh > 0 Then GetFileSize_ = GetFileSize_ + (iFileSizeHigh * 4294967296@)

End Function

#9

Good luck,new babier!

#10

mark

秒客网

请问如何用vb遍历一个文件夹下的所有文件包括自文件夹?

10 个解决方案

#1

#2

#3

#4

#5

#6

#7

#8

#9

#10

#1

#2

#3

#4

#5

#6

#7

#8

#9

#10

相关文章