1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

    Yours,
    Chandoo
  2. 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...

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

Discussion in 'VBA Macros' started by Monty, Jan 16, 2017.

  1. Monty

    Monty Well-Known Member

    Messages:
    631
    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.
  2. Monty

    Monty Well-Known Member

    Messages:
    631
    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 (vb):

    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: Jan 17, 2017
  3. Monty

    Monty Well-Known Member

    Messages:
    631
    Guys.

    Any Qucik help..

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

    Thanks
  4. Chihiro

    Chihiro Well-Known Member

    Messages:
    2,998
  5. Monty

    Monty Well-Known Member

    Messages:
    631
    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.
  6. Monty

    Monty Well-Known Member

    Messages:
    631
    Sorry for any confusion and typo errors...working through mobile.
  7. Deepak

    Deepak Excel Ninja

    Messages:
    2,689
    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.

    Attached Files:

  8. Monty

    Monty Well-Known Member

    Messages:
    631
    Hey Deepak

    Thank u...Noted concern.

    Will check it attachment....Many thanks.
  9. Chihiro

    Chihiro Well-Known Member

    Messages:
    2,998
    Does the code run fine if you exclude "SenderName"?

    If not, then I suspect syntax error here.
    Code (vb):
     folder.Items.Item(iRow).SenderName
    Perhaps change it to...
    Code (vb):
     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 (vb):
    If folder.Items.Item(iRow).Class = olMail Then
    'Your code
    End If
    Last edited: Jan 17, 2017
  10. Deepak

    Deepak Excel Ninja

    Messages:
    2,689
    As well using multiple dots in a single line is not a good idea too.

    You may ref like as below.
    Code (vb):

    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 (vb):

                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.
  11. Monty

    Monty Well-Known Member

    Messages:
    631
    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.
  12. Chihiro

    Chihiro Well-Known Member

    Messages:
    2,998
    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 (vb):
            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.
  13. Monty

    Monty Well-Known Member

    Messages:
    631
    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.
  14. Deepak

    Deepak Excel Ninja

    Messages:
    2,689
    Date issue might occurred due to any mismatch in format. I will check and insure the needful soon.
    Monty likes this.
  15. Monty

    Monty Well-Known Member

    Messages:
    631
    Great...You deserve like.:)
  16. Chihiro

    Chihiro Well-Known Member

    Messages:
    2,998
    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.

    Attached Files:

  17. Monty

    Monty Well-Known Member

    Messages:
    631
    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.
  18. Chihiro

    Chihiro Well-Known Member

    Messages:
    2,998
    Woops :oops: My bad. I forgot to remove comment out from when I was running few tests. Use this one.

    Attached Files:

  19. Monty

    Monty Well-Known Member

    Messages:
    631
    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 (vb):
    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
     
  20. Chihiro

    Chihiro Well-Known Member

    Messages:
    2,998
    Change it like below.
    Code (vb):
    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
  21. Monty

    Monty Well-Known Member

    Messages:
    631
    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...
  22. Chihiro

    Chihiro Well-Known Member

    Messages:
    2,998
    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).
  23. Monty

    Monty Well-Known Member

    Messages:
    631
    Good morning.


    Error attached

    Attached Files:

  24. Deepak

    Deepak Excel Ninja

    Messages:
    2,689
    Change that to below & check.

    Code (vb):

    .Cells(intRow, 3) = oMail.Subject
     
  25. Monty

    Monty Well-Known Member

    Messages:
    631
    Hey Deepak.

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

Share This Page