VBA获取共享文件夹文件LastModified Date耗时过长问题求助

我看了你的代码，问题核心在于反复通过FileDateTime访问共享文件夹——每次调用这个函数都要发起一次独立的网络请求，文件数量多的时候，频繁的网络交互自然会拖慢整个过程。另外你的代码里还有个拼写小错误（SourcPath应该是SourcePath），虽然不影响运行，但会让逻辑变得冗余混乱。

下面给你两个优化方案，速度都会比原代码提升很多：

方案一：使用FileSystemObject（FSO）批量读取属性 #

FSO可以一次性获取目标文件夹下的所有文件集合，之后直接遍历集合读取修改时间，大幅减少网络交互的次数：

Public Sub CountTextFilesInFolder_optimized()
    Dim fso As Object
    Dim targetFolder As Object
    Dim fileItem As Object
    Dim folderPath As String
    Dim fileCount As Long
    
    folderPath = "\\SVTickets\"
    ' 统一路径格式，确保结尾带反斜杠
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    ' 捕获共享文件夹访问失败的情况
    On Error Resume Next
    Set targetFolder = fso.GetFolder(folderPath)
    On Error GoTo 0
    
    If Not targetFolder Is Nothing Then
        fileCount = 0
        ' 遍历文件夹内所有文件，筛选txt格式
        For Each fileItem In targetFolder.Files
            If LCase(fso.GetExtensionName(fileItem.Name)) = "txt" Then
                fileCount = fileCount + 1
                ' 直接从文件对象读取修改时间，无需额外网络请求
                Dim lastModifyTime As Date
                lastModifyTime = fileItem.DateLastModified
                ' 这里可以添加你的后续处理逻辑，比如打印或写入单元格
                ' Debug.Print fileItem.Name & " : " & lastModifyTime
            End If
        Next fileItem
        MsgBox "共找到 " & fileCount & " 个txt文件"
    Else
        MsgBox "无法访问目标共享文件夹，请检查路径或权限"
    End If
    
    ' 释放对象，避免内存泄漏
    Set fileItem = Nothing
    Set targetFolder = Nothing
    Set fso = Nothing
End Sub

方案二：使用Windows API（最快方案） #

如果你的共享文件夹里有大量文件，API调用是最优选择——它直接和系统底层交互，跳过了VBA层的封装开销，速度提升最明显：

Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As Currency
    ftLastAccessTime As Currency
    ftLastWriteTime As Currency
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * 260
    cAlternate As String * 14
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 Declare PtrSafe Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As LongPtr
Private Declare PtrSafe Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As LongPtr, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare PtrSafe Function FindClose Lib "kernel32" (ByVal hFindFile As LongPtr) As Long
Private Declare PtrSafe Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As Currency, lpLocalFileTime As Currency) As Long
Private Declare PtrSafe Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As Currency, lpSystemTime As SYSTEMTIME) As Long

Public Sub GetTxtFilesWithAPI()
    Dim folderPath As String
    Dim searchPattern As String
    Dim hFindHandle As LongPtr
    Dim findData As WIN32_FIND_DATA
    Dim sysTime As SYSTEMTIME
    Dim lastModifyTime As Date
    Dim fileCount As Long
    
    folderPath = "\\SVTickets\"
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    searchPattern = folderPath & "*.txt"
    
    hFindHandle = FindFirstFile(searchPattern, findData)
    If hFindHandle <> -1 Then
        fileCount = 0
        Do
            ' 跳过子目录，只处理文件
            If (findData.dwFileAttributes And vbDirectory) = 0 Then
                fileCount = fileCount + 1
                ' 将系统文件时间转换为本地可读的日期时间
                FileTimeToLocalFileTime findData.ftLastWriteTime, findData.ftLastWriteTime
                FileTimeToSystemTime findData.ftLastWriteTime, sysTime
                lastModifyTime = DateSerial(sysTime.wYear, sysTime.wMonth, sysTime.wDay) + _
                             TimeSerial(sysTime.wHour, sysTime.wMinute, sysTime.wSecond)
                ' 后续处理逻辑
                ' Debug.Print Left(findData.cFileName, InStr(findData.cFileName, vbNullChar) - 1) & " : " & lastModifyTime
            End If
        Loop While FindNextFile(hFindHandle, findData)
        
        ' 关闭查找句柄
        FindClose hFindHandle
        MsgBox "共找到 " & fileCount & " 个txt文件"
    Else
        MsgBox "未找到目标文件，或无法访问共享文件夹"
    End If
End Sub

额外优化建议 #

• 访问共享文件夹时一定要加错误处理，避免网络中断、权限不足等情况导致程序崩溃；
• 如果需要将结果写入Excel单元格，建议先把所有数据存到数组里，最后一次性写入，避免循环中频繁的IO操作拖慢速度。

内容的提问来源于stack exchange，提问作者user2717144