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

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 )

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

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

membership

This solution is only available to members.