Outlook使用宏Excel

Question

我的查询是，我有下面的 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

Answer 1

我注意到以下代码：

 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 类的 Find/FindNext 或 Restrict 方法。以下文章深入介绍了它们：

• How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
• How To: Use Restrict method to retrieve Outlook mail items from a folder

Answer 2

删除 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