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
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