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