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!
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")
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
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")
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
Do more with
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Hi,
You could use
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\"
Error Message - runtime error 2147467259 (80004005) Method file dialog of object failed on line With Application.FileDialog(mso
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(mso
.AllowMultiSelect = False
.Show
strFolderName = .SelectedItems(1)
End With
If strFolderName = "" Then strFolderName = "\\cdc.gov\private\L327\xb
' rsChild.Fields("FileData")
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
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(mso
.AllowMultiSelect = False
.Show
strFolderName = .SelectedItems(1)
End With
If strFolderName = "" Then strFolderName = "\\cdc.gov\private\L327\xb
' rsChild.Fields("FileData")
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")
with
rsChild.Fields("FileData")
rsChild.Fields("FileData")
with
rsChild.Fields("FileData")
Error Message - runtime error 2147467259 (80004005) Method file dialog of object failed on line With Application.FileDialog(mso
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(mso
.AllowMultiSelect = False
.Show
strFolderName = .SelectedItems(1)
End With
If strFolderName = "" Then strFolderName = "\\cdc.gov\private\L327\xb
rsChild.Fields("FileData")
'rsChild.Fields("FileData"
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
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(mso
.AllowMultiSelect = False
.Show
strFolderName = .SelectedItems(1)
End With
If strFolderName = "" Then strFolderName = "\\cdc.gov\private\L327\xb
rsChild.Fields("FileData")
'rsChild.Fields("FileData"
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
The code works, however it prompts me for each file... I need to export all the attachments with only one prompt...
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
Premium Content
You need an Expert Office subscription to comment.Start Free Trial