Microsoft Outlook is one the best email processing application used by user on daily basis. Sometimes, it is used for bulk data transfer medium. users sending bulk emails consist of lots of attached file of various extension such as excel (Microsoft Excel), word (Microsoft Word), PDF (Adobe), Text files, Images (Photoshop file) and so on. Then, it becomes very tedious job to handle large number of attachment in Microsoft Outlook. Saving bulk attachment into specific folder takes lot of productive time which definitely impact on other activities.
Using excel VBA code this task can be automate which will definitely save lot of productive hours. This, VBA code will take hardly 5 minutes to save attachment into specific folder of your Personal Computer.
Sub Save_email_attachment_to_folder()
' Author: Dreams24
' Written for VBA Tricks and tips blog
'Parameter 1 = Folder name of folder inside your Inbox e.g. Test_Folder
'Parameter 2 = File extension, "" is every file e.g. .xls, .pdf, .doc and so on.
'Parameter 3 = Save folder, "C:\Users\Dreams\Desktop\Test_Folder" or ""
' If you use "" it will create a date/time stamped folder for you in your "Documents" folder
' Note: If you use this "C:\Users\Dreams\Desktop\Test_Folder\" the folder must exist.
Save_Email_Attachments_To_Folder "Test", "", "C:\Users\Dreams\Desktop\Test_Folder"
End Sub
Write Below function just below above macro:
Function Save_Email_Attachments_To_Folder(OutlookFolderInInbox As String, ExtString As String, DestFolder As String)
' Author: Dreams24
' Written for VBA Tricks and tips blog
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim i As Integer
Dim wsh As Object
Dim fs As Object
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error GoTo Handle_err:
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
i = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
vbInformation, "Nothing Found"
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Function
End If
'Create DestFolder when folder not exists
If DestFolder = "" Then
Set wsh = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
MyDocPath = wsh.SpecialFolders.Item("mydocuments")
DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
If Not fs.FolderExists(DestFolder) Then
fs.CreateFolder DestFolder
End If
End If
If Right(DestFolder, 1) <> "\" Then
DestFolder = DestFolder & "\"
End If
' Check each message for attachments and extensions
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & " " & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
' Show this message when Finished
If i > 0 Then
MsgBox "Please Browse below path for your files: " _
& DestFolder, vbInformation, "Finished!"
Else
MsgBox "No attached files in your mail.", vbInformation, "Finished!"
End If
' Code to Release memory
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set fs = Nothing
Set wsh = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Function
' Code for Error Handling
Handle_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: Save_email_attachment_to_folder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
No comments:
Post a Comment