我的前同事建立了一个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
最佳答案
经过两天的挖掘,我可以弄清楚自己想要什么。
现在,我可以将所有附件从数据库导出到给定的文件夹,将图片的路径和名称插入数据库,然后将数据库的大小从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
关于vba - 如何将具有给定名称的附件(图像)导出到文件夹?,我们在Stack Overflow上找到一个类似的问题:https://stackoverflow.com/questions/39382384/