MS Access：特定の名前の添付ファイル（イメージ）をフォルダにエクスポートする方法は？

Question

私の元同僚は、多数のレコードセットを持つアクセスデータベースを構築し、それぞれに1〜5枚の写真が添付されています。データベースのサイズは現在かなり大きく（約2 GB）、実際には遅いです。悪いニュースは、より多くのデータが毎日入ってくるということです:(

私はそれを修正する必要があります。私のアイデアは、データベースの添付ファイルに画像を含める代わりに、パスと画像の名前を保存するだけです

今、私がしなければならないことは、既存のすべての画像（約3000枚の写真）を次の場所から書き出す方法を見つけることです。名前をIMG _ ####に似ているため、データベースの名前を変更した後にフォルダに移動します（エクスポートの後に手動で名前を変更して名前を変更する必要はありません）。 If私は成功しました.DBのサイズが大幅に縮小され、パフォーマンスが向上しました。それは夢です！ どうすればいいですか？

私はインターネット上で何かを見つけました。しかし、最初のレコードセットの添付ファイルだけをエクスポートします。これを私の必要性にどのように変えることができますか？

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

2日間の掘削後、私は欲しいものを見つけ出すことができました。 これで、データベースからすべての添付ファイルを特定のフォルダにエクスポートし、画像のパスと名前をデータベースに挿入し、データベースのサイズを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