Export Email Data from Outlook to Excel

Keerthiv

New Member
Joined
Aug 29, 2019
Messages
14
Hi,

I have this below code which works perfectly fine. I need help to achieve 3 more tasks.

1. The number of attachments should not count if the file extension is png
2. The files with extension png should be shown or exported
3. Is there a way that the attachment(s) itself can be downloaded/attached as an object against each email


Option Explicit
Sub GetMailInfo()

Dim results() As String


'To get contacts
results = ExportEmails(True)

' Paste the values
Range(Cells(1, 1), Cells(UBound(results), UBound(results, 2))).Value = results

MsgBox "Success!!! Your intended task is complete!", vbInformation, "Keerthi's Automation"
End Sub

Function ExportEmails(Optional headerRow As Boolean = False) As String()

Dim objOutlook As Object
Dim objNamespace As Object
Dim strFolderName As Object
Dim objMailbox As Object
Dim objFolder As Object
Dim mailFolderItems As Object
Dim folderItem As Object
Dim msg As Object
Dim tempString() As String
Dim i As Long
Dim numRows As Long
Dim startRow As Long
Dim jAttach As Long
Dim debugMsg As Integer

' select output results worksheet and clear previous results
Sheets("Outlook Results").Select
Sheets("Outlook Results").Cells.ClearContents
Range("A1").Select

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set strFolderName = objNamespace.PickFolder
Set mailFolderItems = strFolderName.Items

' Condition if calling procedure wants header row
If headerRow Then
startRow = 1
Else
startRow = 0
End If

numRows = mailFolderItems.Count

' resize array / data selection
ReDim tempString(1 To (numRows + startRow), 1 To 100)

' loop through the selected folder items
For i = 1 To numRows
Set folderItem = mailFolderItems.Item(i)

If IsMail(folderItem) Then
Set msg = folderItem
End If

With msg
tempString(i + startRow, 3) = .cc
tempString(i + startRow, 5) = .ReceivedTime
tempString(i + startRow, 1) = .SenderName
tempString(i + startRow, 4) = .Subject
tempString(i + startRow, 2) = .To
tempString(i + startRow, 6) = .Attachments.Count
'tempString(i + startRow, 6) = .Body

End With

' Name of attachments
If msg.Attachments.Count > 0 Then

For jAttach = 1 To msg.Attachments.Count
tempString(i + startRow, 6 + jAttach) = msg.Attachments.Item(jAttach).DisplayName
Next jAttach

End If

Next i

' Assuming first row has header values
If headerRow Then

tempString(1, 3) = "cc"
tempString(1, 5) = "ReceivedTime"
tempString(1, 1) = "SenderName"
tempString(1, 4) = "Subject"
tempString(1, 2) = "To"
'tempString(1, 6) = "Content of Email"
tempString(1, 6) = "Number of Attachments"
tempString(1, 7) = "Attachment 1 Filename"
tempString(1, 8) = "Attachment 2 Filename"
tempString(1, 9) = "Attachment 3 Filename"
tempString(1, 10) = "Attachment 4 Filename"
tempString(1, 11) = "Attachment 5 Filename"
tempString(1, 12) = "Attachment 6 Filename"
tempString(1, 13) = "Attachment 7 Filename"
tempString(1, 14) = "Attachment 8 Filename"
tempString(1, 15) = "Attachment 9 Filename"
tempString(1, 16) = "Attachment 10 Filename"
tempString(1, 17) = "Attachment 11 Filename"
tempString(1, 18) = "Attachment 12 Filename"
tempString(1, 19) = "Attachment 13 Filename"
tempString(1, 20) = "Attachment 14 Filename"
tempString(1, 21) = "Attachment 15 Filename"
tempString(1, 22) = "Attachment 16 Filename"
tempString(1, 23) = "Attachment 17 Filename"
tempString(1, 24) = "Attachment 18 Filename"
tempString(1, 25) = "Attachment 19 Filename"
tempString(1, 26) = "Attachment 20 Filename"
End If

ExportEmails = tempString

' apply pane freeze and filtering

Range("A1").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
'Selection.AutoFilter

End Function
Function IsMail(itm As Object) As Boolean
IsMail = (TypeName(itm) = "MailItem")
End Function
 

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand

Forum statistics

Threads
1,223,886
Messages
6,175,191
Members
452,616
Latest member
intern444

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top