I've borowed a module from www.fontstuff.com
The code saves email attachments from outlook folders to regular file system folders.
Everything works great if the folder being saved to isn't a sub folder. For instance, if I just save to "d:" it works fine. But if I try to save to "d:temp", the file is saved on "d:" and appends "temp" to the beginning of the file name it just saved. Does anyone know how to save to a sub folder?
The code I'm using is below (error handling is commented out for debug purposes):
Sub SaveAttachments()
'On Error GoTo SaveAttachments_err
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Outlook.Attachment
Dim FileName As String
Dim i As Integer
Dim appOl As New Outlook.Application
Dim FolderPath As String
Set ns = appOl.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
FolderPath = "d:\temp"
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
FileName = FolderPath & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
If i > 0 Then
MsgBox "There were " & i & " attached files " _
& vbCrLf & "That have been saved to " & FolderPath & "." & vbCr _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
Else
MsgBox "There were no attached files in your mail.", vbInformation, _
"Finished!"
End If
SaveAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
'SaveAttachments_err:
'MsgBox "An unexpected error has occurred." _
'& vbCrLf & "I don't think any files were saved." _
'& vbCrLf & "Macro Name: SaveAttachments" _
' & vbCrLf & "Error Number: " & Err.Number _
'& vbCrLf & "Error Description: " & Err.Description _
', vbCritical, "Error!"
' Resume SaveAttachments_exit
End Sub
The code saves email attachments from outlook folders to regular file system folders.
Everything works great if the folder being saved to isn't a sub folder. For instance, if I just save to "d:" it works fine. But if I try to save to "d:temp", the file is saved on "d:" and appends "temp" to the beginning of the file name it just saved. Does anyone know how to save to a sub folder?
The code I'm using is below (error handling is commented out for debug purposes):
Sub SaveAttachments()
'On Error GoTo SaveAttachments_err
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Outlook.Attachment
Dim FileName As String
Dim i As Integer
Dim appOl As New Outlook.Application
Dim FolderPath As String
Set ns = appOl.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
FolderPath = "d:\temp"
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
FileName = FolderPath & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
If i > 0 Then
MsgBox "There were " & i & " attached files " _
& vbCrLf & "That have been saved to " & FolderPath & "." & vbCr _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
Else
MsgBox "There were no attached files in your mail.", vbInformation, _
"Finished!"
End If
SaveAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
'SaveAttachments_err:
'MsgBox "An unexpected error has occurred." _
'& vbCrLf & "I don't think any files were saved." _
'& vbCrLf & "Macro Name: SaveAttachments" _
' & vbCrLf & "Error Number: " & Err.Number _
'& vbCrLf & "Error Description: " & Err.Description _
', vbCritical, "Error!"
' Resume SaveAttachments_exit
End Sub
