vba - 如何将具有给定名称的附件(图像)导出到文件夹？

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