Question

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

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

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

我在互联网上找到了一些东西。但它只是导出第一个记录集的附件。我怎么能根据自己的需要修改呢？

<dependency>
    <groupId>com.github.redfish4ktc.soapui</groupId>
    <artifactId>maven-soapui-extension-plugin</artifactId>
    <version>4.6.4.0</version>
</dependency>

<dependency>
    <groupId>net.java.dev.jgoodies</groupId>
    <artifactId>looks</artifactId>
    <version>2.1.4</version>
</dependency>
<dependency>
    <groupId>net.sf.squirrel-sql.thirdparty-non-maven</groupId>
    <artifactId>com-fifesoft-rsyntaxtextarea</artifactId>
    <version>1.0.0</version>
</dependency>
<dependency>
    <groupId>org.apache.karaf.eik.plugins</groupId>
    <artifactId>org.apache.commons.collections</artifactId>
    <version>3.2.1</version>
</dependency>

Answer 1

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

如果您有任何疑问，请询问。这是代码：

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

创建一个新模块

从菜单中：

创建->模块（位于右上角）

创建以下功能（大多数是从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）

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

2 个答案: