Vba 使用宏将Outlook转换为excel

我的问题是，我有以下vba代码试图提取特定日期的outlook内容-但我的问题是，每当我尝试运行此代码时，所有电子邮件都会被提取，而不管我所需的日期是什么：-

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

---

我注意到以下代码：

 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)

事实上，Do循环将被忽略，您将使用以下循环在文件夹中迭代所有项目：

For Each olMail In Fldr.Items

您需要改用Items类的/或方法。以下文章对它们进行了深入的描述：

---

移除Do循环和For循环内部以及另一个外部If/then语句，并根据您的日期规格进行调整：

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

---

这不起作用，宏将继续运行，并且不会显示结果。我以前尝试过这个方法，然后切换到Do循环而不是IF。一些建议：在

DateValue（olMail.ReceivedTime）

上使用debug.Print或Msgbox查看它是否与

dStart

对齐；明确定义您在

fldr

中使用的，而不是当前的；使用

DateValue（）

将dstart转换为日期类型；或者检查Outlook文件夹中的数据项是否在指定日期实际存在。