Outlook to excel using macros

Question

My query is , i have below vba code trying to extract the outlook contents of a Particular Date - but my issue is whenever i try to run this code all the emails irrespective of the my required dates are being extracted:-

Sub GetFromInbox()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Object
Dim i As Integer
Dim Dstr As Date
Dim itms As Outlook.Items
Dim filteredItms As Outlook.Items

On Error GoTo err

dStart = Application.InputBox("Enter you start date in MM/DD/YYYY")

If dStart = Empty Then
MsgBox "Start date cannot be empty, please run it again"
Exit Sub
End If


Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.Application.ActiveExplorer.CurrentFolder
MsgBox Fldr
    i = 2

Do
For Each olMail In Fldr.Items

  If olMail.Subject = "Test - 153EN" Then
        Sheet3.Range(Cells(2, 8), Cells(2, 100)).ClearContents
        Sheet3.Cells(i, 1).Value = olMail.Subject
        Sheet3.Cells(i, 2).Value = olMail.ReceivedTime
        Sheet3.Cells(i, 3).Value = olMail.Sender

        i = i + 1
    End If

Next olMail
Loop Until (DateValue(olMail.ReceivedTime) = dStart)
err:
'Display the error message in Status bar
If err.Number > 0 Then
Application.StatusBar = err.Description
MsgBox "Err#" & err.Number & "  " & err.Description
End If
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing

End Sub

score 0 · Answer 1 · answered Feb 26 '15 at 12:30

I have noticed the following code:

 Do
  For Each olMail In Fldr.Items

  If olMail.Subject = "Test - 153EN" Then
    Sheet3.Range(Cells(2, 8), Cells(2, 100)).ClearContents
    Sheet3.Cells(i, 1).Value = olMail.Subject
    Sheet3.Cells(i, 2).Value = olMail.ReceivedTime
    Sheet3.Cells(i, 3).Value = olMail.Sender

    i = i + 1
  End If

 Next olMail
Loop Until (DateValue(olMail.ReceivedTime) = dStart)

The fact is that the Do loop is ignored and you iterate over all items in the folder using the following loop inside:

For Each olMail In Fldr.Items

You need to use the Find/FindNext or Restrict methods of the Items class instead. The following articles describe them in depth:

score 0 · Answer 2 · answered Feb 26 '15 at 14:12

0

Remove the Do Loop and inside the For Loop and another outer If/then statement conditioned to your date specification:

For Each olMail In Fldr.Items
      If (DateValue(olMail.ReceivedTime) = dStart) Then
             If olMail.Subject = "Test - 153EN" Then 
                  Sheet3.Range(Cells(2, 8), Cells(2, 100)).ClearContents 
                  Sheet3.Cells(i, 1).Value = olMail.Subject 
                  Sheet3.Cells(i, 2).Value = olMail.ReceivedTime 
                  Sheet3.Cells(i, 3).Value = olMail.Sender

                  i = i + 1 
             End If
      End If
Next olMail

answered Feb 26 '15 at 14:12

Parfait

104,375
17
94
125

This does not work, the macro keeps running and not results are displayed. I have tried this before and then switched to Do loops instead of IF. – Yoga Raj Feb 26 '15 at 15:44
Some suggestions: use debug.Print or Msgbox on `DateValue(olMail.ReceivedTime)` to see if it aligns with `dStart`; explicitly define your [Outlook folder](http://stackoverflow.com/questions/28387823/excel-vba-open-outlook-email-in-specific-folder-and-download-attachments/28388456#28388456) used in `fldr` instead of current one; convert dstart to date type using `DateValue()`; or check to see if data items in Outlook folder actually exists at the specified date. – Parfait Feb 27 '15 at 01:36

Outlook to excel using macros

2 Answers2