VBA to pull emails from outlook

vaibhav tandon

New Member
Joined
Jun 5, 2012
Messages
10
Hi all,
Need help on macro to pull information from outlook.
I have gone through the previous threads but not able to customize the solution to suit my need. I have taken the code / file from following link "https://www.vishalon.net/blog/expor...-meta-data-into-excel/comment-page-3#comments" and it works fine but I need to hardcode certain folders/subfolders to remove human interference and get the data in excel.
For example I have shared email boxes and it has Inbox as a folder and WIP, closed, issue etc as subfolders. I want to hardcode these folder names so that I get all the emails from all these sub folders either in the same excel file or in different excel file.
Could somebody help me with this?


**Code:**


Option Explicit
' Got this code from http://superuser.com/questions/8162...ile-name-email-metadata-from-outlook-to-excel
Sub GetMailInfo()


Dim results() As String


' get contacts
results = ExportEmails(True)


' paste onto worksheet
Range(Cells(1, 1), Cells(UBound(results), UBound(results, 2))).Value = results


MsgBox "Completed"
End Sub


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


Dim objOutlook As Object ' Outlook.Application
Dim objNamespace As Object ' Outlook.Namespace
Dim strFolderName As Object
Dim objMailbox As Object
Dim objFolder As Object
Dim mailFolderItems As Object ' Outlook.items
Dim folderItem As Object
Dim msg As Object ' Outlook.MailItem
Dim tempString() As String
Dim i As Long
Dim numRows As Long
Dim startRow As Long
Dim jAttach As Long ' counter for attachments
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")
'MsgBox objOutlook, vbOKOnly 'for debugging
Set objNamespace = objOutlook.GetNamespace("MAPI")
'MsgBox objNamespace, vbOKOnly 'for debugging
'Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
'MsgBox objInbox, vbOKOnly 'for debugging
Set strFolderName = objNamespace.PickFolder
Set mailFolderItems = strFolderName.Items


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


numRows = mailFolderItems.Count


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


' loop through 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, 1) = .BCC
tempString(i + startRow, 2) = .BillingInformation
'tempString(i + startRow, 3) = Left$(.Body, 900) ' throws error without limit
tempString(i + startRow, 4) = .BodyFormat
tempString(i + startRow, 5) = .Categories
tempString(i + startRow, 6) = .cc
tempString(i + startRow, 7) = .Companies
tempString(i + startRow, 8) = .CreationTime
tempString(i + startRow, 9) = .DeferredDeliveryTime
tempString(i + startRow, 10) = .DeleteAfterSubmit
tempString(i + startRow, 11) = .ExpiryTime
tempString(i + startRow, 12) = .FlagDueBy
tempString(i + startRow, 13) = .FlagIcon
tempString(i + startRow, 14) = .FlagRequest
tempString(i + startRow, 15) = .FlagStatus
tempString(i + startRow, 16) = .Importance
tempString(i + startRow, 17) = .LastModificationTime
tempString(i + startRow, 18) = .Mileage
tempString(i + startRow, 19) = .OriginatorDeliveryReportRequested
tempString(i + startRow, 20) = .Permission
tempString(i + startRow, 21) = .ReadReceiptRequested
tempString(i + startRow, 22) = .ReceivedByName
tempString(i + startRow, 23) = .ReceivedOnBehalfOfName
tempString(i + startRow, 24) = .ReceivedTime
tempString(i + startRow, 25) = .RecipientReassignmentProhibited
tempString(i + startRow, 26) = .ReminderSet
tempString(i + startRow, 27) = .ReminderTime
tempString(i + startRow, 28) = .ReplyRecipientNames
tempString(i + startRow, 29) = .SenderEmailAddress
tempString(i + startRow, 30) = .SenderEmailType
tempString(i + startRow, 31) = .SenderName
tempString(i + startRow, 32) = .Sensitivity
tempString(i + startRow, 33) = .SentOn
tempString(i + startRow, 34) = .Size
tempString(i + startRow, 35) = .Subject
tempString(i + startRow, 36) = .To
tempString(i + startRow, 37) = .VotingOptions
tempString(i + startRow, 38) = .VotingResponse
tempString(i + startRow, 39) = .Attachments.Count


End With


' adding file attachment names where they exist - added by JP
If msg.Attachments.Count > 0 Then


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


End If


Next i


' first row of array should be header values
If headerRow Then


tempString(1, 1) = "BCC"
tempString(1, 2) = "BillingInformation"
tempString(1, 3) = "Body"
tempString(1, 4) = "BodyFormat"
tempString(1, 5) = "Categories"
tempString(1, 6) = "cc"
tempString(1, 7) = "Companies"
tempString(1, 8) = "CreationTime"
tempString(1, 9) = "DeferredDeliveryTime"
tempString(1, 10) = "DeleteAfterSubmit"
tempString(1, 11) = "ExpiryTime"
tempString(1, 12) = "FlagDueBy"
tempString(1, 13) = "FlagIcon"
tempString(1, 14) = "FlagRequest"
tempString(1, 15) = "FlagStatus"
tempString(1, 16) = "Importance"
tempString(1, 17) = "LastModificationTime"
tempString(1, 18) = "Mileage"
tempString(1, 19) = "OriginatorDeliveryReportRequested"
tempString(1, 20) = "Permission"
tempString(1, 21) = "ReadReceiptRequested"
tempString(1, 22) = "ReceivedByName"
tempString(1, 23) = "ReceivedOnBehalfOfName"
tempString(1, 24) = "ReceivedTime"
tempString(1, 25) = "RecipientReassignmentProhibited"
tempString(1, 26) = "ReminderSet"
tempString(1, 27) = "ReminderTime"
tempString(1, 28) = "ReplyRecipientNames"
tempString(1, 29) = "SenderEmailAddress"
tempString(1, 30) = "SenderEmailType"
tempString(1, 31) = "SenderName"
tempString(1, 32) = "Sensitivity"
tempString(1, 33) = "SentOn"
tempString(1, 34) = "size"
tempString(1, 35) = "subject"
tempString(1, 36) = "To"
tempString(1, 37) = "VotingOptions"
tempString(1, 38) = "VotingResponse"
tempString(1, 39) = "Number of Attachments"
tempString(1, 40) = "Attachment 1 Filename"
tempString(1, 41) = "Attachment 2 Filename"
tempString(1, 42) = "Attachment 3 Filename"
tempString(1, 43) = "Attachment 4 Filename"
tempString(1, 44) = "Attachment 5 Filename"
tempString(1, 45) = "Attachment 6 Filename"
tempString(1, 46) = "Attachment 7 Filename"
tempString(1, 47) = "Attachment 8 Filename"
tempString(1, 48) = "Attachment 9 Filename"
tempString(1, 49) = "Attachment 10 Filename"
tempString(1, 50) = "Attachment 11 Filename"
tempString(1, 51) = "Attachment 12 Filename"
tempString(1, 52) = "Attachment 13 Filename"
tempString(1, 53) = "Attachment 14 Filename"
tempString(1, 54) = "Attachment 15 Filename"
tempString(1, 55) = "Attachment 16 Filename"
tempString(1, 56) = "Attachment 17 Filename"
tempString(1, 57) = "Attachment 18 Filename"
tempString(1, 58) = "Attachment 19 Filename"
tempString(1, 59) = "Attachment 20 Filename"
End If


ExportEmails = tempString


' apply pane freeze and filtering


Range("A2").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
 

Some videos you may like

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number

Watch MrExcel Video

Forum statistics

Threads
1,127,595
Messages
5,625,711
Members
416,129
Latest member
karthickerfolg

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
Top