Export Emails from Outlook to Excel

[Keerthivasan]

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 not be shown or exported
3. Is there a way that the attachment(s) itself can be downloaded/attached as an object against each email

>>> use code - tags <<
​

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