如何将具有给定名称的附件（图像）导出到文件夹？

Question

我的前同事建立了一个Access数据库，里面有很多记录集，每个记录集附有一到五张图片。数据库的大小现在非常大（大约 2 GB）而且速度非常慢。

我没有将图片包含在数据库附件中，而是将图片的路径和名称作为字符串存储在列中，然后在需要时调用它们。

现在我必须在重命名它们之后将所有现有图像（大约 3000 张图片）从数据库导出到一个文件夹（它们的描述存储在数据库的另一列中，因为现在它们的名字就像 IMG_## ##，我不想在导出后手动查找和重命名它们）。

我在网上找到了一些东西。但它只导出第一个记录集的附件。我该如何修改它以满足我的需要？

Dim strPath As String
Dim rs As DAO.Recordset
Dim rsPictures As Variant
strPath = Application.CurrentProject.Path

'????How to loop through all record set???
'  Instantiate the parent recordset.
   Set rs = CurrentDb.OpenRecordset("Assets")

   ' Instantiate the child recordset.
   Set rsPictures = rs.Fields("Attachments").Value

   '  Loop through the attachments.
   While Not rsPictures.EOF
       '????How to rename the picture???

      '  Save current attachment to disk in the "My Documents" folder.
      rsPictures.Fields("FileData").SaveToFile strPath & "\Attachment"
      rsPictures.MoveNext
   Wend

Answer 1

经过两天的挖掘，我可以弄清楚我想要什么。现在，我可以将所有附件从数据库导出到给定的文件夹，将图片的路径和名称插入数据库并将我的数据库从 2GB 调整为 8MB！是的！

如有问题请追问。这是相关代码：

sub exportAttachments()

Dim strPath, fName, fldName, sName(3)  As String
Dim rsPictures, rsDes  As Variant
Dim rs As DAO.Recordset
Dim savedFile, i As Integer
savedFile = 0

strPath = Application.CurrentProject.Path

Set rs = CurrentDb.OpenRecordset("SELECT * FROM Employees")

'Check to see if the recordset actually contains rows
If Not (rs.EOF And rs.BOF) Then
    rs.MoveFirst 'Not required here, but still a good habit
    Do Until rs.EOF = True        
        On Error Resume Next 'ignore errors

       'Instantiate the child record set.
        Set rsPictures = rs.Fields("Attachments").Value
        Set rsDes = rs.Fields("Name") 'use to name the picture later

        'if no attachment available, go to next record
        If Len(rsPictures.Fields("FileName")) = 0 Then
         GoTo nextRS
        End If
        If rsPictures.RecordCount <> 0 Then 
        rsPictures.MoveLast
        savedFile = rsPictures.RecordCount 'set savedFile = total no of attachments
        End If
    rsPictures.MoveFirst ' move to first attachment file

  'WARNING: all of my attachments are picture with JPG extension. 
  'loop through all attachments
        For i = 1 To savedFile 'rename all files and save
            If Not rsPictures.EOF Then
                fName = strPath & "\Attachments\" & rsDes & i & ".JPG"
                rsPictures.Fields("FileData").SaveToFile fName
                sName(i) = fName 'keep path in an array for later use
                rsPictures.MoveNext
            End If
        Next i

        'insert image name and path into database an edit
        rs.Edit

            If Len(sName(1)) <> 0 Then
                rs!PicPath1 = CStr(sName(1)) 'path
                rs!PicDes1 = Left(Dir(sName(1)), InStr(1, Dir(sName(1)), ".") - 1) 'file name without extension
            End If
            If Len(sName(2)) <> 0 Then
                rs!PicPath2 = CStr(sName(2))
                rs!PicDes2 = Left(Dir(sName(2)), InStr(1, Dir(sName(2)), ".") - 1)
            End If
            If Len(sName(3)) <> 0 Then
                rs!PicPath3 = CStr(sName(3))
                rs!PicDes3 = Left(Dir(sName(3)), InStr(1, Dir(sName(3)), ".") - 1)
            End If

        rs.Update 'update record
nextRS:
        rsPictures.Close 'close attachment
        savedFile = 0 'reset for next
        fName = 0 'reset

        'Move to the next record.
     rs.MoveNext
    Loop

Else
    MsgBox "There are no records in the recordset."
End If

MsgBox "Attachments were exported!"

rs.Close 'Close the db recordsets
Set rs = Nothing 'Clean up

End Sub

Answer 2

创建新模块

从菜单中：

创建 -> 模块（在右上角）

创建以下函数（主要是 copy/paste 来自 Microsoft 文档）

    Public Function SaveAttachments(strPath As String, Optional strPattern As String = "*.*") As Long
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset2
    Dim rsA As DAO.Recordset2
    Dim fld As DAO.Field2
    Dim strFullPath As String
    
    'Get the database, recordset, and attachment field
    Set dbs = CurrentDb

    '
    ' MODIFY THIS LINE
    '
    Set rst = dbs.OpenRecordset("NAME_OF_THE_TABLE")
    '
    ' MODIFY THIS LINE
    '
    Set fld = rst("TABLE_FIELD_WITH_THE_ATTACHMENTS")
    
    'Navigate through the table
    Do While Not rst.EOF
    
        'Get the recordset for the Attachments field
        Set rsA = fld.Value
        
        'Save all attachments in the field
        Do While Not rsA.EOF
            If rsA("FileName") Like strPattern Then
                strFullPath = strPath & "\" & rsA("FileName")
                
                'Make sure the file does not exist and save
                If Dir(strFullPath) = "" Then
                    rsA("FileData").SaveToFile strFullPath
                End If
                
                'Increment the number of files saved
                SaveAttachments = SaveAttachments + 1
            End If
            
            'Next attachment
            rsA.MoveNext
        Loop
        rsA.Close
        
        'Next record
        rst.MoveNext
    Loop
    
    rst.Close
    dbs.Close
    
    Set fld = Nothing
    Set rsA = Nothing
    Set rst = Nothing
    Set dbs = Nothing
End Function

Sub ExportData()
  '
  ' MODIFY THIS LINE
  '
  SaveAttachments ("PATH_TO_THE_DIRECTORY_WHERE_YOU_WANT_THE_FILES_STORED")
End Sub

然后运行这个(F5)

如何将具有给定名称的附件（图像）导出到文件夹？

How to export attachments (images) with a given name to a folder?

ms-access

vba

export

attachment