Access VBA Prompt User For Save Folder

shieldsco
shieldsco used Ask the Experts™
on
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
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Top Expert 2016

Commented:
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

Author

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
Top Expert 2016

Commented:
replace

 rsChild.Fields("FileData").SaveToFile ("\\cdc.gov\private\L327\xbn8\Attachments\")
with
   rsChild.Fields("FileData").SaveToFile (strFolderName )
Ensure you’re charging the right price for your IT

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!

Author

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
Top Expert 2016

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

Author

Commented:
I have reference to MS 15.0

Author

Commented:
The code works, however it prompts me for each file... I need to export all the attachments with only one prompt...
Top Expert 2016
Commented:
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

Author

Commented:
Thanks

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial