Access VBA Prompt User For Save Folder

Hi,

You could use

With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    strFolderName = .SelectedItems(1)
End With
if strFolderName = "" then strFolderName  = "\\cdc.gov\private\L327\xbn8\Attachments\"

Select allOpen in new window

Regards

Error Message - runtime error 2147467259 (80004005) Method file dialog of object failed on line      With Application.FileDialog(msoFileDialogFolderPicker)


Private Sub Export_Attachment_Click()
'On Error GoTo Err_SaveImage

 Dim db As DAO.Database
 Dim rsParent As DAO.Recordset2
 Dim rsChild As DAO.Recordset2

 Set db = CurrentDb
 Set rsParent = db.OpenRecordset("select * from tbl_MOU")

  Do Until rsParent.EOF
       Set rsChild = rsParent.Fields("Open ISA_MOU").Value
       rsChild.OpenRecordset
       If rsChild.RecordCount <> 0 Then
           
           
     With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    strFolderName = .SelectedItems(1)
End With
If strFolderName = "" Then strFolderName = "\\cdc.gov\private\L327\xbn8\Attachments\"
           
           
           
          ' rsChild.Fields("FileData").SaveToFile ("\\cdc.gov\private\L327\xbn8\Attachments\")
       End If
       rsChild.Close
       Set rsChild = Nothing
       rsParent.MoveNext
   Loop

Exit_SaveImage:

Set rsChild = Nothing
Set rsParent = Nothing
 Exit Sub

Err_SaveImage:

 If Err = 3839 Then
 MsgBox ("File Already Exists in the Directory!")
 Resume Next

 Else
'MsgBox "Some Other Error occured!", Err.Number, Err.Description
 Resume Exit_SaveImage

 End If

End Sub

replace

 rsChild.Fields("FileData").SaveToFile ("\\cdc.gov\private\L327\xbn8\Attachments\")
with
   rsChild.Fields("FileData").SaveToFile (strFolderName )

Error Message - runtime error 2147467259 (80004005) Method file dialog of object failed on line      With Application.FileDialog(msoFileDialogFolderPicker)

Code:


Private Sub Export_Attachment_Click()
 On Error GoTo Err_SaveImage

 Dim db As DAO.Database
 Dim rsParent As DAO.Recordset2
 Dim rsChild As DAO.Recordset2

 Set db = CurrentDb
 Set rsParent = db.OpenRecordset("select * from tbl_MOU")

  Do Until rsParent.EOF
       Set rsChild = rsParent.Fields("Open ISA_MOU").Value
       rsChild.OpenRecordset
       If rsChild.RecordCount <> 0 Then
       
       With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    strFolderName = .SelectedItems(1)
End With
If strFolderName = "" Then strFolderName = "\\cdc.gov\private\L327\xbn8\Attachments\"

   
       
    rsChild.Fields("FileData").SaveToFile (strFolderName)
       
       
           'rsChild.Fields("FileData").SaveToFile ("\\cdc.gov\private\L327\xbn8\Attachments\")
       End If
       rsChild.Close
       Set rsChild = Nothing
       rsParent.MoveNext
   Loop

Exit_SaveImage:

Set rsChild = Nothing
Set rsParent = Nothing
 Exit Sub

Err_SaveImage:

 If Err = 3839 Then
 MsgBox ("File Already Exists in the Directory!")
 Resume Next

 Else
 MsgBox "Some Other Error occured!", Err.Number, Err.Description
 Resume Exit_SaveImage

 End If

End Sub

Sorry you need the ref to Microsoft Office 15.0(not sure) Object Library to use Application.filedialog

I have reference to MS 15.0

The code works, however it prompts me for each file... I need to export all the attachments with only one prompt...

Thanks