Access VBA导出PDF未导出文件名显示报错及代码优化求助

• 新编写的代码（第一段）尝试收集并显示导出失败的文件名，但执行failedFileNames = failedFileNames & vbCrLf & failedFile时触发*「对象无效或不再设置」*错误
• 此前使用的第二段代码可正常导出500个PDF，但新代码仅导出480个
• 需求：优化代码或提供替代方案，确保正确显示所有未导出的文件名

原始代码 #

第一段（带失败收集的问题代码） #

Sub ExportPDFs()
    Dim rs As DAO.Recordset
    Dim folder As String, path As String
    Dim adoStream As Object 'Late bound ADODB.Stream
    Dim failedFiles As New Collection 'list of failed files
    Dim failedFileNames As String 'A string to hold the names of failed files
    
    folder = "F:\rkp\archive  packing\tarhebasteh\"
    Set rs = CurrentDb.OpenRecordset("SELECT namemotor , FILE FROM tarhebasteh")
    
    failedFileNames = "" 'Definition and initialization
    
    Do Until rs.EOF
        path = folder & rs!namemotor & ".pdf"
        
        Set adoStream = CreateObject("ADODB.Stream")
        adoStream.Type = 1 'adTypeBinary
        adoStream.Open
        adoStream.Write rs("FILE").Value
        
        On Error Resume Next
        adoStream.SaveToFile path, adSaveCreateOverWrite
        If Err.Number <> 0 Then 'If an error occurs
            failedFiles.Add rs!namemotor ' Add filename to failure list
        End If
        On Error GoTo 0
        
        adoStream.Close
        rs.MoveNext
    Loop
    
    rs.Close
    Set rs = Nothing
    
    'Show failed files
    If failedFiles.Count > 0 Then
        Dim failedFile As Variant
        For Each failedFile In failedFiles
            failedFileNames = failedFileNames & vbCrLf & failedFile
        Next failedFile
        MsgBox "The following files were not output:" & vbCrLf & vbCrLf & failedFileNames
    Else
        MsgBox "All files have been moved to the output."
    End If
End Sub

第二段（可正常导出的代码） #

Sub ExportPDFs()
    Dim rs As DAO.Recordset
    Dim folder As String, path As String
    Dim adoStream As Object 'Late bound ADODB.Stream
    
    folder = "C:\Users\AliReza\Desktop\folder\"
    Set rs = CurrentDb.OpenRecordset("SELECT Name, Package FROM documents")
    Do Until rs.EOF
        path = folder & rs!Name & ".pdf"
        
        Set adoStream = CreateObject("ADODB.Stream")
        adoStream.Type = 1 'adTypeBinary
        adoStream.Open
        adoStream.Write rs("Package").Value
        adoStream.SaveToFile path, adSaveCreateOverWrite
        adoStream.Close
        
        rs.MoveNext
    Loop
    
    rs.Close
    Set rs = Nothing
End Sub

问题分析与优化方案 #

核心错误原因 #

1. 「对象无效或不再设置」错误：On Error Resume Next会掩盖SaveToFile之外的错误（比如rs!namemotor读取失败），导致添加到集合的是无效对象而非字符串；此外，记录集可能因前置错误导致状态异常，无法正常读取字段值。
2. 导出数量减少：新代码的错误处理逻辑可能跳过了部分记录，或者文件夹路径中的空格未被正确解析，导致部分路径无效。

优化后的代码 #

Sub ExportPDFs_Enhanced()
    Dim rs As DAO.Recordset
    Dim folder As String, path As String
    Dim adoStream As Object
    Dim failedFiles As New Collection
    Dim failedFileNames As String
    Dim currentMotorName As String ' 提前保存当前记录的文件名，避免记录集失效
    
    ' 确保文件夹路径格式正确
    folder = "F:\rkp\archive  packing\tarhebasteh\"
    If Right(folder, 1) <> "\" Then folder = folder & "\"
    
    ' 使用dbOpenDynaset打开记录集，确保稳定性
    Set rs = CurrentDb.OpenRecordset("SELECT namemotor, FILE, ID FROM tarhebasteh", dbOpenDynaset)
    
    Do Until rs.EOF
        ' 提前读取并保存文件名，处理空值情况
        currentMotorName = Nz(rs!namemotor, "未知文件_" & rs!ID)
        path = folder & currentMotorName & ".pdf"
        
        ' 初始化Stream对象
        Set adoStream = CreateObject("ADODB.Stream")
        adoStream.Type = 1 ' adTypeBinary
        adoStream.Open
        
        ' 定向错误处理，精准捕获导出异常
        On Error GoTo ExportError
        adoStream.Write rs("FILE").Value
        adoStream.SaveToFile path, 2 ' 2对应adSaveCreateOverWrite，避免依赖库引用
        adoStream.Close
        Set adoStream = Nothing
        
        rs.MoveNext
        GoTo NextRecord ' 跳过错误处理块
        
ExportError:
    ' 收集失败信息，包含错误详情
    failedFiles.Add currentMotorName & " (错误: " & Err.Number & " - " & Err.Description & ")"
    ' 清理Stream对象
    If Not adoStream Is Nothing Then
        adoStream.Close
        Set adoStream = Nothing
    End If
    ' 继续处理下一条记录
    rs.MoveNext
    
NextRecord:
    Loop
    
    ' 清理记录集
    rs.Close
    Set rs = Nothing
    
    ' 显示失败列表
    If failedFiles.Count > 0 Then
        Dim failedFile As Variant
        failedFileNames = ""
        For Each failedFile In failedFiles
            failedFileNames = failedFileNames & vbCrLf & "- " & failedFile
        Next failedFile
        MsgBox "以下文件导出失败:" & vbCrLf & vbCrLf & failedFileNames, vbExclamation, "导出结果"
    Else
        MsgBox "所有文件已成功导出!", vbInformation, "导出完成"
    End If
End Sub

关键优化点 #

• 提前保存文件名：在操作Stream前读取rs!namemotor并存入变量，避免记录集因错误失效后无法获取文件名
• 定向错误处理：替换On Error Resume Next为On Error GoTo，仅捕获导出相关错误，避免掩盖其他逻辑问题
• 空值处理：用Nz函数处理空的namemotor字段，结合ID生成唯一文件名，避免无效路径
• 数值常量替代：直接使用2代替adSaveCreateOverWrite，无需引用ADODB库
• 对象清理：确保每次循环后关闭并释放Stream对象，避免内存泄漏或状态异常
• 路径校验：自动补全文件夹路径末尾的斜杠，避免路径拼接错误

内容的提问来源于Stack Exchange，提问作者Alireza Daneshmayeh