It’s been sometime now that I had made a post, Been busy with some personal stuff and a major project, professionally.
As I observed, there are teams that monitor mailbox and have to keep track of the emails that are sent to them, this then is required to generate metrics for Management Review.
Wouldn’t it be nice if after selecting emails I could port the data to excel and save attachments to a folder?
Copy this code to Outlook ( not Excel ) . In Outlook , Press Alt + F11 and paste code in This Outlook session, You will need to close and restart Outlook.
‘———————————————————————-
Sub CopyToExcel()
‘ Change Variables only here
‘ File name goes here
BaseFileName = “Outlook to Excel.xlsx”
‘ Folder goes here
BaseFolderName = “C:\Users\XXXYYY\Desktop\Outlook Auto”
SheetName = “Data”
‘ Do not change code below
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim obj As Object
Dim strColB, strColC, strColD, strColE, strColF, strColG As String
Dim objAtt As Outlook.Attachment
Basefile = BaseFolderName & “\” & BaseFileName
dateFormat = Format(Now, “yyyy-mm-dd H-mm”)
‘ Create the Folders
saveFolder = BaseFolderName & “\Attachments\”
If Len(Dir(saveFolder, vbDirectory)) = 0 Then
MkDir (saveFolder)
MsgBox (“Attachments Folder Creted on : ” & saveFolder)
End If
saveFolder = BaseFolderName & “\Attachments\” & dateFormat
If Len(Dir(saveFolder, vbDirectory)) = 0 Then MkDir (saveFolder)
strPath = Basefile
On Error Resume Next
Set xlApp = GetObject(, “Excel.Application”)
If Err <> 0 Then
Application.StatusBar = “Please wait while Excel source is opened … ”
Set xlApp = CreateObject(“Excel.Application”)
bXStarted = True
End If
On Error GoTo 0
‘Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets(SheetName)
‘ Process the message record
On Error Resume Next
‘Find the next empty line of the worksheet
rCount = xlSheet.Range(“B” & xlSheet.Rows.Count).End(-4162).Row
‘needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1
‘ get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection
Set olItem = obj
‘collect the fields
strColC = olItem.SenderEmailAddress
strColB = olItem.SenderName
strColD = olItem.Body
strColE = olItem.To
strColF = olItem.ReceivedTime
strColG = olItem.Subject
For Each objAtt In olItem.Attachments
objAtt.SaveAsFile saveFolder & “\” & objAtt.DisplayName
Attachs = Attachs & “,” & objAtt.DisplayName
Set objAtt = Nothing
Next
strColH = Attachs
strColI = saveFolder
‘ Get the Exchange address
‘ if not using Exchange, this block can be removed
Dim olEU As Outlook.ExchangeUser
Dim oEDL As Outlook.ExchangeDistributionList
Dim recip As Outlook.Recipient
Set recip = Application.Session.CreateRecipient(strColC)
If InStr(1, strColC, “/”) > 0 Then
‘ if exchange, get smtp address
Select Case recip.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
End Select
End If
‘ End Exchange section
‘write them in the excel sheet
xlSheet.Range(“B” & rCount) = strColB
xlSheet.Range(“c” & rCount) = strColC
xlSheet.Range(“d” & rCount) = strColD
xlSheet.Range(“e” & rCount) = strColE
xlSheet.Range(“f” & rCount) = strColF
xlSheet.Range(“g” & rCount) = strColG
xlSheet.Range(“h” & rCount) = strColH
xlSheet.Range(“i” & rCount) = strColI
‘Next row
rCount = rCount + 1
Next
‘xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set olItem = Nothing
Set obj = Nothing
Set currentExplorer = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
‘———————————————————————-
Now when you run this macro, The Attachments will be saved in folder and data copied to Excel last row.
A new folder will be created and attachments save.
Attached is the file to play with, Hope this eases a lot of manual work out there.
Next you can run a macro on the recently downloaded attachements, Just with a click.
Cheers
CuriousJatin
Curios by Nature 