How to extract mail items from multiple folders and shared mailboxes?

Status
Not open for further replies.

sn152

Member
Outlook version
Outlook 2007
Email Account
Exchange Server
Hi All,

I have the below code which will extract the mail items from an outlook folder to an excel file. When I run this macro, it will ask me to pick a folder.
Instead of that, is there a way to extract mail items from multiple folders and shared mailboxes? Please help me with this.

Code:
Option Explicit
 Sub CopyToExcel()

 Dim xlApp As Object
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim rCount As Long
 Dim bXStarted As Boolean
 Dim enviro As String
 Dim strPath As String
 Dim fld As Outlook.MAPIFolder
 Dim nms As Outlook.NameSpace
 Dim currentExplorer As Explorer
 Dim Selection As Selection
 Dim olItem As Outlook.MailItem
 Dim obj As Object
 Dim strColB, strColC, strColD, strColE, strColF, strColG, strColH, strColI As String
               
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder

If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If

' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
 strPath = "C:\Users\ABC\Desktop\Book1.xlsx"
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Please wait while Excel source is opened ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0
     'Open the workbook to input the data
     Set xlWB = xlApp.Workbooks.Open(strPath)
     Set xlSheet = xlWB.Sheets("Sheet1")
    ' Process the message record
   
    On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1

' get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
 
  For Each obj In fld.Items

    Set olItem = obj
   
 'collect the fields
   
    strColB = olItem.SenderName
    strColC = olItem.SenderEmailAddress
    strColD = olItem.Subject
    strColE = olItem.To
    strColF = olItem.ReceivedTime
    strColG = olItem.Categories
    strColH = olItem.FlagRequest
    strColI = olItem.Parent

' Get the Exchange address
' if not using Exchange, this block can be removed
 Dim olEU As Outlook.ExchangeUser
 Dim oEDL As Outlook.ExchangeDistributionList
 Dim recip As Outlook.Recipient
 Set recip = Application.Session.CreateRecipient(strColC)

 If InStr(1, strColC, "/") > 0 Then
' if exchange, get smtp address
     Select Case recip.AddressEntry.AddressEntryUserType
       Case OlAddressEntryUserType.olExchangeUserAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
             strColC = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olOutlookContactAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
            strColC = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
         Set oEDL = recip.AddressEntry.GetExchangeDistributionList
         If Not (oEDL Is Nothing) Then
            strColC = olEU.PrimarySmtpAddress
         End If
     End Select
End If
' End Exchange section

'write them in the excel sheet
  xlSheet.Range("B" & rCount) = strColB
  xlSheet.Range("c" & rCount) = strColC
  xlSheet.Range("d" & rCount) = strColD
  xlSheet.Range("e" & rCount) = strColE
  xlSheet.Range("f" & rCount) = strColF
  xlSheet.Range("g" & rCount) = strColG
  xlSheet.Range("h" & rCount) = strColH
  xlSheet.Range("i" & rCount) = strColI
 
'Next row
  rCount = rCount + 1

 Next

     xlWB.Close 1
     If bXStarted Then
         xlApp.Quit
     End If
     Set nms = Nothing
     Set olItem = Nothing
     Set obj = Nothing
     Set currentExplorer = Nothing
     Set xlApp = Nothing
     Set xlWB = Nothing
     Set xlSheet = Nothing
 End Sub
 
Status
Not open for further replies.
Thread starter Similar threads Forum Replies Date
N Extract Outlook emails to excel Outlook VBA and Custom Forms 2
M Extract all links from Outlook email, send to Excel Using Outlook 2
T Extract Data From Outlook Tasks Using Outlook 0
T Extract Data From Outlook Tasks Using Outlook 0
V extract users of a particular department Outlook VBA and Custom Forms 1
J Outlook 2013 Extract Flag Completed dates to Excel Macro Outlook VBA and Custom Forms 16
K Extract email address from body and auto-reply outlook Using Outlook 1
R Trying to extract information between two symbols from outlook subject Using Outlook 2
K Extract email to excel from a specific sender Outlook VBA and Custom Forms 3
O VBA to extract email (fields and body) to Excel Outlook VBA and Custom Forms 14
P Recover / Extract Rules from standalone PST file creating RWZ file Using Outlook 2
B Extract Dates for Appointment Item in Body of email Outlook VBA and Custom Forms 10
D Need to extract a line from a word attachment, and add it to the subject line Outlook VBA and Custom Forms 3
E Extract excel files from outlook Outlook VBA and Custom Forms 2
K extract certain text from an Outlook Email Message Outlook VBA and Custom Forms 2
D VBA Script to extract text matching specific criteria Outlook VBA and Custom Forms 1
M Extract text in existing message body for use in newmail items Using Outlook 17
M HELP--Extract Data from 2003 outlook transfer to excel spreadsheet Using Outlook 1
M VBA Code to extract data from an Outlook Form Using Outlook 0
M Extract attachments with a script Using Outlook 0
M HELP - Can't open outlook... How can I extract my Emails that I had in folders Using Outlook 3
H Extract emails from Outlokk 2007 email body Using Outlook 0
K Extract Global Address List Using Outlook 1
E I am trying to extract the email adress's i have in outlook. These are not saved 'contacts' these are ones from auto fill. When i open up an email, an Using Outlook 1
L How to extract table format of Task Item if its body contains formatted table. Exchange Server Administration 1
D Extract email addresses from inbox in a batch and move them into "bcc" for a mass email campaign Using Outlook 1
M Extract, zip and replace attachement in each message of a pst file Using Outlook 0
R Saving Outlook Email As Text File Extract Outlook VBA and Custom Forms 2
N Programming to extract automatically extract attachments Outlook VBA and Custom Forms 3
S How to extract outlook calendar data. Outlook VBA and Custom Forms 3
? outlook attachment Extract File ??? Outlook VBA and Custom Forms 1
D Extract Data from OST File Using Outlook 2
N How to extract date and time stamp from messsages Outlook VBA and Custom Forms 6
V Extract Subject,Sent From, Message from mailbox to Excel Outlook VBA and Custom Forms 5
S Automatically extract attachments? Outlook VBA and Custom Forms 1
I How to extract email addresses from TO or CC line of a particular email Outlook VBA and Custom Forms 2
ThinkToday Calculate reply time of outlook mail Using Outlook 1
B Outlook 2010 Opening Mail Attachment Using Outlook 2
e_a_g_l_e_p_i Is it possible it set the fonts used to read incoming mail Using Outlook 11
D Mail in Sent Items Gone Using Outlook 13
M Managing Gmail "All Mail" sync issues with IMAP Using Outlook 1
GregS Outlook 2016 Sent Mail absent from Sent Mail or Sent Items Folders Using Outlook 4
GregS Why is Outlook 2016 mail in Outlook.com? Using Outlook 1
S Outlook not receiving mail Using Outlook 2
Commodore Outlook (2013) issues with icloud.com mail Using Outlook 0
GregS Outlook 2016 iPhone won't download Outlook 2016 Mail. Using Outlook 0
A Arthur needs help with 2007 Outlook e-mail Using Outlook.com accounts in Outlook 3
oliv- How to distinguish whether mail is incoming or outgoing? Outlook VBA and Custom Forms 2
W Receiving mail for account that has been deleted Using Outlook 2
H In outlook 365 POP mail Inbox, email takes a long time or never arrives. Using Outlook 1
Similar threads


















































Top