• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

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

Monty

Well-Known Member
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

Well-Known Member
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
 
Last edited by a moderator:

Monty

Well-Known Member
Guys.

Any Qucik help..

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

Thanks
 

Monty

Well-Known Member
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.
 

Deepak

Excel Ninja
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.
 

Attachments

Chihiro

Excel Ninja
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
 
Last edited:

Deepak

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

Well-Known Member
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

upload_2017-1-18_0-26-26.png

Screenshot 2

upload_2017-1-18_0-25-45.png

Screenshot 3

upload_2017-1-18_0-26-6.png


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

Chihiro

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

Well-Known Member
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.
 

Chihiro

Excel Ninja
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.
 

Attachments

Monty

Well-Known Member
Hello Chihiro..

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

upload_2017-1-18_3-52-56.png

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

Monty

Well-Known Member
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

upload_2017-1-18_4-19-25.png
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

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

Well-Known Member
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

Excel Ninja
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).
 
Top