如何将给定名称的附件(图像)导出到文件夹?

问题描述

我的前同事建立了一个 Access 数据库，其中包含许多记录集，每个记录集都附有 1 到 5 张图片.数据库的大小现在非常大(大约 2 GB)，而且速度非常慢.

My ex-colleague built an Access database with many record sets and each of them has one to five pictures attached. The size of the database is now really big (about 2 GB) and it is really slow.

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

I managed instead of including the pictures in the database attachment, to just store the path and the name of the picture as strings in the columns and then recall them whenever I need to do that.

现在我必须将所有现有图像(约 3000 张图片)在重命名后从数据库导出到一个文件夹(将它们的描述存储在数据库的另一列中，因为现在它们的名称类似于 IMG_####，并且我不想在导出后手动查找和重命名它们).

Now I have to export all of the existing images (about 3000 pictures) from the database to a folder after renaming them (with their description stored in another column in the DB, because now their names are like IMG_####, and I don't want to find AND rename them manually after exporting).

我在互联网上找到了一些东西.但它只导出第一个记录集的附件.我怎样才能根据需要修改它?

I've found something on the internet. But it just exports the attachment of the first record set only. How could I modify this to my need?

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

推荐答案

经过两天的挖掘，我找到了我想要的东西.现在，我可以将数据库中的所有附件导出到给定文件夹，将图片的路径和名称插入数据库并将我的数据库大小从 2GB 调整为 8MB！是的！

after two days digging, I could figure out what I wanted.Now, I can export all the attachments from the database to a given folder, insert the path and name of the picture into the database and resize my database from 2GB to 8MB! YESSS!

如果您有问题，请提问.这是代码:

Please ask,if you had questions.Here is the code for that:

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

这篇关于如何将给定名称的附件(图像)导出到文件夹?的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！