Vba Code to Export outlook emails of current date for a folder to excel

Monty · Jan 16, 2017

Hello Experts.

Need a quick help.

need a urgent on Vba Code to Export outlook emails of current date for a folder to excel when u run vba code which is attached to button.

on a daily basis when we click on a button on excel...should get the emails with subject and senders name to excel and append..

Thanks.

Monty · Jan 16, 2017

Hello Experts.

Below is the code which i was using since year...but need to ammend the code.

when user click on the button on excel should get only current date emails and ammend to excel..

Code:

Sub Outlook_Mail_To_Excel()
Dim folders As Outlook.folders
Dim folder As Outlook.MAPIFolder
Dim iRow As Integer
Dim Pst_Folder_Name
Dim MailboxName



'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session)
MailboxName = "Some@gmail.com"

'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
Pst_Folder_Name = "Inbox"

Set folder = Outlook.Session.folders(MailboxName).folders(Pst_Folder_Name)
If folder = "" Then
    MsgBox "Invalid Data in Input"
    GoTo end_lbl1:
End If

'Rad Through each Mail and export the details to Excel for Email Archival
Sheets(1).Activate

For iRow = 1 To folder.Items.Count
    Sheets(1).Cells(iRow, 1).Select
    Sheets(1).Cells(iRow, 1) = folder.Items.Item(iRow).SenderName
    Sheets(1).Cells(iRow, 2) = folder.Items.Item(iRow).Subject
    Sheets(1).Cells(iRow, 3) = folder.Items.Item(iRow).ReceivedTime
    Sheets(1).Cells(iRow, 4) = folder.Items.Item(iRow).Size
    Sheets(1).Cells(iRow, 5) = folder.Items.Item(iRow).SenderEmailAddress
    'Sheets(1).Cells(iRow, 6) = Folder.Items.Item(iRow).Body
Next iRow
MsgBox "Outlook Mails Extracted to Excel"

end_lbl1:

End Sub

Monty · Jan 17, 2017

Guys.

Any Qucik help..

Error at : Sheets(1).Cells(iRow, 1) = folder.Items.Item(iRow).SenderName

Thanks

Chihiro · Jan 17, 2017

Upload sample workbook with your code. Your description of issue is incomplete.

Also, see Debaser's post in below thread on how to restrict items returned from the folder.

http://chandoo.org/forum/threads/ca...-mails-for-particuar-dates.29934/#post-179376

Monty · Jan 17, 2017

Chihiro.

Thanks for the response.

I have already have code above...excel workbook is empty...when we run the code..

This should get emails copied to excel...with the following.

Sendername
Subject
Size
Body.

Now the works fine only problem getting the sendername.

If we comment sender name it works

Error at : Sheets(1).Cells(iRow, 1) = folder.Items.Item(iRow).SenderName

Hope this help...let me know still looking for attachment..

Thanks.

Monty · Jan 17, 2017

Sorry for any confusion and typo errors...working through mobile.

Deepak · Jan 17, 2017

Pls always use code tags as I did for #2.
Have you checked the same in break mode.

I am attaching a xl which I developed little back but lots of optimisation is pending in that. This might help you.

Monty · Jan 17, 2017

Hey Deepak

Thank u...Noted concern.

Will check it attachment....Many thanks.

Chihiro · Jan 17, 2017

Does the code run fine if you exclude "SenderName"?

If not, then I suspect syntax error here.

Code:

 folder.Items.Item(iRow).SenderName

Perhaps change it to...

Code:

 folder.Items(iRow).SenderName

Edit: Oh wait Outlook folder item syntax is correct with original. You should check type of item and ensure that it is mail.

Code:

If folder.Items.Item(iRow).Class = olMail Then
'Your code
End If

Deepak · Jan 17, 2017

As well using multiple dots in a single line is not a good idea too.

You may ref like as below.

Code:

Dim o as mailitem
o = folder.Items.Item(iRow) 

Sheets(1).Cells(iRow, 1) = o.SenderName

Below is outlook code snippet from another project having almost all your requirements.

Code:

            Set BUNCH_OF_Items = CurrentFolder.Items
                 
                    Set filtereditmsextract1 = BUNCH_OF_Items.Restrict("[ReceivedTime] >= '" & Format(StartDate, "ddddd h:nn AMPM") & "' And [ReceivedTime] <= '" & Format(EndDate, "ddddd ") & "11:59 PM" & "'")
                    Extract1 = filtereditmsextract1.Count
                   
                    For i = 1 To Extract1
                    On Error Resume Next
                   
                    '''Only for Poland Project == Strat ==
                    LineCat = WConf.Sheets("ExcludeCategory").Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
                   
                    If LineCat > 1 Then
                    FINDCat = filtereditmsextract1.Item(i).Categories
                        If FINDCat <> "" Then
                            Set WsConfCat = WConf.Sheets("ExcludeCategory")
                            WsConfCat.Activate
                            Set FOUNDCELLCat = WsConfCat.Range("A:A").Find(What:=FINDCat, LookAt:=xlWhole, LookIn:=xlValues) 'change this range
                                If Not FOUNDCELLCat Is Nothing Then
                                GoTo NextItem
                                End If
                        End If
                    '''Only for Poland Project == End ==
                    End If
                   
                    Line = wks.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1
                    wks.Range("A" & Line) = filtereditmsextract1.Item(i).Attachments.Count 'IIf(UCase(CurrentFolder.Name) = "SENT ITEMS", "Sent Email", "Received Email") 'CurrentFolder.FolderPath
                    wks.Range("B" & Line) = CurrentFolder.Store.DisplayName
                    wks.Range("C" & Line) = filtereditmsextract1.Item(i).Categories
                    wks.Range("D" & Line) = filtereditmsextract1.Item(i).To
                    wks.Range("E" & Line) = filtereditmsextract1.Item(i).SenderName
                    wks.Range("F" & Line) = filtereditmsextract1.Item(i).CC
                    'wks.Range("F" & Line) = Left(filteredItmsExtract1.Item(i).Subject, Len(filteredItmsExtract1.Item(i).Subject) - Len(filteredItmsExtract1.Item(i).ConversationTopic))
                       
                     '   Select Case UCase(Trim(wks.Range("F" & Line).Value))
                     '   Case "RE:", "FW:", "FWD:", "AW:", "WG:", "SV:", "VS:", "VL:", "TR:", "R:", "RIF:", "I:", "FS:", "VB:", "RV:", "RES:", "ENC:", "ODP:", "PD:", "YNT:", "ILT:", "ACCEPTED:", "DECLINED:", "TENTATIVE:", "PROPOSE NEW TIME:"
                     '   Case Else
                     '   wks.Range("F" & Line) = "New"
                     '   End Select
                   
                    wks.Range("G" & Line) = filtereditmsextract1.Item(i).ConversationTopic
                    'wks.Range("H" & Line) = filteredItmsExtract1.Item(i).Body
                    wks.Range("H" & Line) = CurrentFolder.FolderPath 'CurrentFolder.Name
                    wks.Range("I" & Line) = filtereditmsextract1.Item(i).ReceivedTime
                    wks.Range("P" & Line) = filtereditmsextract1.Item(i).Attachments.Item(1).DisplayName '.Item(i).FileName
                    'wks.Range("J" & Line) = GetLastVerb(filtereditmsextract1.Item(i)) 'filteredItmsExtract1.Item(i).LastModificationTime
                   
                    'convert date
                    Dim stemp As String
                    stemp = GetLastVerb(filtereditmsextract1.Item(i))
                    If IsDate(stemp) Then
                    wks.Range("J" & Line).Value = CDate(stemp)
                    Else
                    wks.Range("J" & Line).Value = stemp
                    End If
                   
                    If wks.Range("J" & Line) <> "" Then
                    wks.Range("A" & Line) = Round(wks.Range("J" & Line) - wks.Range("I" & Line), 0)
                    Else
                    wks.Range("N" & Line) = Round(Now() - wks.Range("I" & Line), 0)
                    End If
                   
                    wks.Range("K" & Line) = (Len(filtereditmsextract1.Item(i).ConversationIndex) - 44) / 10 'VBA.IIf((filteredItmsExtract1.Item(i).UnRead), "Yes", "No")
                    wks.Range("M" & Line) = CurrentFolder.Name
                    wks.Range("O" & Line) = Now()
                    saveAttachments_1 filtereditmsextract1.Item(i), MakeFolders & "\"

NextItem:
                    filtereditmsextract1.Item(i) = Nothing
                    Next i

Replied from mobile. Will check at my pc tommorow & let u know the cause.

Monty · Jan 17, 2017

Hello Guys...Thanks for the best replys.

Deepak : I must say you are champ...it's working great..it has great interface to retrieve mails form outlook.

But i have few points....Please help

1) When we are selecting dates...still trying to retrive all mails.
2) macro stops after retrieving 483 mails.

Attaching screenshot for your idea.

Screenshot 1

Screenshot 2

Screenshot 3

But must say...This is the one of the best macro i have seen till date...Thanks champ.

Chihiro · Jan 17, 2017

Deepak's code is meant to export attachments to specified folder.

So, date parameters are used to save attachments found in that range to a folder. All emails in specified folders are outputted into the sheet.

You should move "ImportData2Excel" line found in cmdProcess_Click() sub to If check for date range and also modify argument.

Should look like something like below.

Code:

        If Int(objItem.ReceivedTime) <= inteDate And Int(objItem.ReceivedTime) >= intsDate Then
            emailProcessedData = saveAttachments2(objItem, strF, strExt, cpathE(ostrFolder))
            ImportData2Excel Sheets("output").Cells(Rows.Count, 1).End(xlUp).Row + 1, objItem, strF, atmtCount, strprocessedext
        End If

Couldn't replicate your 2nd issue. Ran about 1000+ emails without issue.

Monty · Jan 17, 2017

Hello Chihiro.

Fantastic macro...But date selection not taking into consideration by the macro ...importing all mails in output sheet perfectly and attachments are saved in a folder.

But based on date it should read mails and show in out put sheet.

Any chance for amendment sir.

Deepak · Jan 17, 2017

Date issue might occurred due to any mismatch in format. I will check and insure the needful soon.

Monty · Jan 17, 2017

Great...You deserve like.

Chihiro · Jan 17, 2017

Hmm.... odd. Tested with afore mentioned modification on my end and worked without issue.

Note: My main has M/d/yyyy format. Tested on another machine that has yy/MM/dd format. Both worked without issue. Even tested on another language, worked fine.

See attached with modification to Deepak's module.

Monty · Jan 17, 2017

Hello Chihiro..

Thanks for testing file for me..Some how file is not responding and not allowing to select the folder.

Still am looking for this to work...Working from my end...I really appreciate if you can help me with this.

Chihiro · Jan 17, 2017

Woops

My bad. I forgot to remove comment out from when I was running few tests. Use this one.

Monty · Jan 17, 2017

Guys..

Worked with small piece of code as per my requirment..

but still we can enhance the code...Screenshot for your reference

1) Data should embed from blank rows as per below screenshot it started from 73 row leaving all blanks at the top.
2) Size should not have decimals.

Still working on this...Hopefully

Code:

Dim n As Long
Sub Launch_Pad()
   
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim Date1
   
    Date1 = Date
   
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.PickFolder
   
   
Call ProcessFolder(olFolder, Date1)
   
    Set olNS = Nothing
    Set olFolder = Nothing
    Set olApp = Nothing
    Set olNS = Nothing
End Sub
Sub ProcessFolder(olfdStart As Outlook.MAPIFolder, Date1)
    Dim olFolder As Outlook.MAPIFolder
    Dim olObject As Object
    Dim olMail As Outlook.MailItem
   
    For Each olObject In olfdStart.Items
        If TypeName(olObject) = "MailItem" Then
           
            If olObject.ReceivedTime >= Date1 Then
                n = n + 1
                Set olMail = olObject
                Cells(n, 1) = n
                Cells(n, 2) = olMail.SenderEmailAddress
                Cells(n, 3) = olMail.Subject
                Cells(n, 4) = olMail.ReceivedTime
                Cells(n, 5) = olMail.SenderName
               
                Cells(n, 6) = olMail.Size / 1024 & " " & "KB"
               
            End If
        End If
    Next
    Set olMail = Nothing
    Set olFolder = Nothing
    Set olObject = Nothing
End Sub

Chihiro · Jan 17, 2017

Change it like below.

Code:

Dim n As Long
Sub Launch_Pad()
  Dim olApp As Outlook.Application
  Dim olNS As Outlook.Namespace
  Dim olFolder As Outlook.MAPIFolder
  Dim Date1
  Date1 = Date
  Set olApp = Outlook.Application
  Set olNS = olApp.GetNamespace("MAPI")
  Set olFolder = olNS.PickFolder
Call ProcessFolder(olFolder, Date1)
  Set olNS = Nothing
  Set olFolder = Nothing
  Set olApp = Nothing
  Set olNS = Nothing
End Sub
Sub ProcessFolder(olfdStart As Outlook.MAPIFolder, Date1)
  Dim olFolder As Outlook.MAPIFolder
  Dim olObject As Object
  Dim olMail As Outlook.MailItem
  n = Cells(Rows.Count, 1).End(xlUp).Row
  For Each olObject In olfdStart.Items
    If TypeName(olObject) = "MailItem" Then
   
      If olObject.ReceivedTime >= Date1 Then
        n = n + 1
        Set olMail = olObject
        Cells(n, 1) = n
        Cells(n, 2) = olMail.SenderEmailAddress
        Cells(n, 3) = olMail.Subject
        Cells(n, 4) = olMail.ReceivedTime
        Cells(n, 5) = olMail.SenderName
     
        Cells(n, 6) = Int(olMail.Size / 1024) & " " & "KB"
     
      End If
    End If
  Next
  Set olMail = Nothing
  Set olFolder = Nothing
  Set olObject = Nothing
End Sub

Monty · Jan 17, 2017

Hello Chihiro.

Thanks for change you made..it works..

one thing noticed whether it's Deepak code or my code it handles not more then 500 mails later getting error...but still holds good.

Thanks a ton...

Chihiro · Jan 17, 2017

I can't help you unless you specify what error code is returned and at what line.

You can try...
The method I mentioned earlier, posted by Debaser to trim down the amount of item you need to loop through (it will restrict the items returned from the folder by condition).

Monty · Jan 18, 2017

Good morning.

Error attached

Deepak · Jan 18, 2017

Change that to below & check.

Code:

.Cells(intRow, 3) = oMail.Subject

Monty · Jan 18, 2017

Hey Deepak.

Still no luck..after changing suggested line of code.

Vba Code to Export outlook emails of current date for a folder to excel

Well-Known Member

Well-Known Member

Well-Known Member

Excel Ninja

Well-Known Member

Well-Known Member

Excel Ninja

Attachments

Well-Known Member

Excel Ninja

Excel Ninja

Well-Known Member

Excel Ninja

Well-Known Member

Excel Ninja

Well-Known Member

Excel Ninja

Attachments

Well-Known Member

Excel Ninja

Attachments

Well-Known Member

Excel Ninja

Well-Known Member

Excel Ninja

Well-Known Member

Attachments

Excel Ninja

Well-Known Member