Hello Guys,
Today, I have bring up with a new topic How to Autosave Multiple Emails in Outlook.
Some times we need to save our sent emails messages to a folder, in such a case, we need to open each message and save the same one by one manually.
We can automate this task through the help of VBA.
For this we just need to run the below macro code and our messages will get saved at specified location.
I am showing here two codes.
1. For saving 50 emails to a sepecific folder
2. For saving all the sent emails to a folder.
So here is the first code of saving 50 emails:
Sub SaveSentEmail_50()
Dim ns As Object
Dim ol As Object
Dim oSent As Object
Dim Item As Object
Dim oTemp As Object
Dim Atmt As Object
Dim Filename, outputpath As String
Dim i As Integer
Dim SubFolder As Object
Dim xName As String
'Set Output Path to Save Sent emails
outputpath = "D:\" 'change output path here
Set ol = GetObject(, "outlook.application")
Set ns = ol.GetNamespace("MAPI")
Set oSent = ns.GetDefaultFolder(olFolderSentMail)
'If you wish to use subfolder in Sent box then change the folder name here
'Set SubFolder = oSent.Folders("Folder1")
'If you wish to use subfolder in Sent box then replace the value of oSent---> subFolder
Set oTemp = oSent
i = 1
If oTemp.Items.Count > 0 Then
For i = 1 To 50
xName = oTemp.Items(i).Subject
oTemp.Items(i).SaveAs outputpath & "\" & xName & ".msg", olMSG
On Error Resume Next
Next
End If
On Error GoTo Get_err
MsgBox "Total " & i & " mails have been saved into " & outputpath
Exit Sub
Get_err:
MsgBox "Unexpected error has occurred"
End Sub
Second VBA Code for saving all the sent emails:
Sub SaveSentEmail_All()
Dim ns As Object
Dim ol As Object
Dim oSent As Object
Dim Item As Object
Dim oTemp As Object
Dim Atmt As Object
Dim Filename, outputpath As String
Dim i As Integer
Dim SubFolder As Object
Dim xName As String
'Set Output Path to Save Sent emails
outputpath = "D:\" 'change output path here
Set ol = GetObject(, "outlook.application")
Set ns = ol.GetNamespace("MAPI")
Set oSent = ns.GetDefaultFolder(olFolderSentMail)
'If you wish to use subfolder in Sent box then change the folder name here
'Set SubFolder = oSent.Folders("Folder1")
'If you wish to use subfolder in Sent box then replace the value of oSent---> subFolder
Set oTemp = oSent
i = 0
If oTemp.Items.Count > 0 Then
For Each Item In oTemp.Items
xName = Item.Subject
Item.SaveAs outputpath & "\" & xName & ".msg", olMSG
On Error Resume Next
i = i + 1
Next Item
End If
On Error GoTo Get_err
MsgBox "Total " & i & " mails have been saved into " & outputpath
Exit Sub
Get_err:
MsgBox "Unexpected error has occurred"
End Sub
Notes:
1. Please change the location of outputpath in the macro code as per your requirement.
2. If you want to extract emails from any specific subfolder under Sent Items, then uncomment the following line and change the name of the Folder1 to your folder's name
Set SubFolder = oSent.Folders("Folder1")
And
Change the assignment of oTemp to subfolder as follows:
Set oTemp = subfolder
Link to download the Excel file contaning macro:
If you want to develop any macro for any office product or automate your task in excel or any other MS office product you can reach out to my Fiverr account:
https://www.fiverr.com/users/sg_2021/seller_dashboard
0 comments:
Post a Comment