Avatar of shieldsco
shieldsco
Flag for United States of America asked on

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
Microsoft AccessVBA

Avatar of undefined
Last Comment
shieldsco

8/22/2022 - Mon
Rgonzo1971

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
shieldsco

ASKER
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
Rgonzo1971

replace

 rsChild.Fields("FileData").SaveToFile ("\\cdc.gov\private\L327\xbn8\Attachments\")
with
   rsChild.Fields("FileData").SaveToFile (strFolderName )
This is the best money I have ever spent. I cannot not tell you how many times these folks have saved my bacon. I learn so much from the contributors.
rwheeler23
shieldsco

ASKER
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
Rgonzo1971

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

ASKER
I have reference to MS 15.0
⚡ FREE TRIAL OFFER
Try out a week of full access for free.
Find out why thousands trust the EE community with their toughest problems.
shieldsco

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

THIS SOLUTION ONLY AVAILABLE TO MEMBERS.
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
See Pricing Options
Start Free Trial
GET A PERSONALIZED SOLUTION
Ask your own question & get feedback from real experts
Find out why thousands trust the EE community with their toughest problems.
shieldsco

ASKER
Thanks