Access带附件字段表迁移SQL Server：按主键自动编号分组导出附件

你的代码核心问题是尝试将附件保存到未预先创建的子文件夹——Windows不允许直接写入不存在的路径，所以必须先为主键对应的编号创建独立文件夹。以下是修复后的完整代码及关键说明：

修复后的VBA代码 #

Function ExtractAttachment()
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset2
    Dim rsA As DAO.Recordset2
    Dim fld As DAO.Field
    Dim savePath As String
    Dim empFolderPath As String
    Dim fso As Object ' FileSystemObject，用于文件夹操作
    
    ' 初始化文件系统对象（后期绑定，无需额外引用）
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 根保存路径，请替换为你的实际路径，确保尾部有斜杠
    savePath = "\\MyFolder\"
    If Right(savePath, 1) <> "\" Then savePath = savePath & "\"
    
    ' 打开记录集，明确包含主键字段（假设主键字段名为EmpID，替换为你表中的实际主键名）
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("SELECT EmpID, EmpPhoto FROM tblEmpInfo")
    
    Do While Not rst.EOF
        ' 构建当前主键对应的文件夹路径
        empFolderPath = savePath & rst!EmpID & "\"
        
        ' 文件夹不存在则创建
        If Not fso.FolderExists(empFolderPath) Then
            fso.CreateFolder empFolderPath
        End If
        
        ' 遍历当前记录的所有附件
        Set fld = rst("EmpPhoto")
        Set rsA = fld.Value
        Do While Not rsA.EOF
            ' 保存附件到对应文件夹，保留原文件名
            rsA.Fields("FileData").SaveToFile empFolderPath
            rsA.MoveNext
        Loop
        
        ' 清理当前记录的附件记录集
        rsA.Close
        rst.MoveNext
    Loop
    
    ' 全局对象清理
    rst.Close
    dbs.Close
    Set rsA = Nothing
    Set fld = Nothing
    Set rst = Nothing
    Set dbs = Nothing
    Set fso = Nothing
End Function

关键改动说明 #

1. 强制创建子文件夹
   使用FileSystemObject检查主键对应的文件夹是否存在，不存在则自动创建——这是解决问题的核心，原代码跳过了这一步导致保存失败。

2. 明确主键字段引用
   用rst!EmpID代替rst.Fields(0)，代码可读性更强，同时避免因表结构调整（比如字段顺序变化）导致的错误，请务必替换为你表中的实际主键字段名。

3. 路径格式校验
   自动补全根路径尾部的斜杠，避免拼接路径时出现类似\\MyFolder123\的错误格式。

4. 优化资源管理
   在循环内及时关闭附件记录集rsA，避免资源泄漏；移除了全局的On Error Resume Next，减少隐藏其他错误的风险。

5. 可选：处理重复文件名
   如果需要避免覆盖已存在的文件，可以在SaveToFile前添加错误捕获逻辑：

   On Error Resume Next
   rsA.Fields("FileData").SaveToFile empFolderPath
   If Err.Number <> 0 Then
       ' 给重复文件添加时间戳后缀
       Dim fileName As String
       fileName = rsA.Fields("FileName")
       fileName = Left(fileName, InStrRev(fileName, ".") - 1) & "(" & Format(Now(), "YYYYMMDDHHMMSS") & ")" & Mid(fileName, InStrRev(fileName, "."))
       rsA.Fields("FileData").SaveToFile empFolderPath & fileName
   End If
   On Error GoTo 0
   

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