Access VBA Prompt User For Save Folder

I'm using the following code to export attachments to a folder on my disk. I would like to modify the code to prompt the user for the save folder.

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
           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
shieldscoAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Rgonzo1971Commented:
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\"

Open in new window

Regards
shieldscoAuthor Commented:
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
Rgonzo1971Commented:
replace

 rsChild.Fields("FileData").SaveToFile ("\\cdc.gov\private\L327\xbn8\Attachments\")
with
   rsChild.Fields("FileData").SaveToFile (strFolderName )
Big Business Goals? Which KPIs Will Help You

The most successful MSPs rely on metrics – known as key performance indicators (KPIs) – for making informed decisions that help their businesses thrive, rather than just survive. This eBook provides an overview of the most important KPIs used by top MSPs.

Get the Guide
shieldscoAuthor Commented:
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
Rgonzo1971Commented:
Sorry you need the ref to Microsoft Office 15.0(not sure) Object Library to use Application.filedialog
shieldscoAuthor Commented:
I have reference to MS 15.0
shieldscoAuthor Commented:
The code works, however it prompts me for each file... I need to export all the attachments with only one prompt...
Rgonzo1971Commented:
then try
 With Application.FileDialog(msoFileDialogFolderPicker)
     .AllowMultiSelect = False
     .Show
     strFolderName = .SelectedItems(1)
 End With
 If strFolderName = "" Then strFolderName = "\\cdc.gov\private\L327\xbn8\Attachments\"
 Do Until rsParent.EOF
        Set rsChild = rsParent.Fields("Open ISA_MOU").Value
        rsChild.OpenRecordset
        If rsChild.RecordCount <> 0 Then
                
            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

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
shieldscoAuthor Commented:
Thanks
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.