如何获取Outlook电子邮件接收时间

Question

我需要从用户首选时间范围内收到的电子邮件中提取附件。

像2PM到4PM之间收到的电子邮件的提取说。

请找到下面的代码我已经完美地提取文件 - 但它为文件夹中的所有电子邮件。

请帮我解决它。

Sub Unzip() 

    Dim ns As NameSpace    'variables for the main functionality 
    Dim Inbox As MAPIFolder 
    Dim SubFolder As MAPIFolder 
    Dim Atchmt As Attachment 
    Dim FileName As Variant 
    Dim msg As Outlook.MailItem 


    Dim FSO As Object    'variables for unzipping 
    Dim oApp As Object 
    Dim FileNameFolder As Variant 
    Dim Totalmsg As Object 
    Dim oFrom 
    Dim oEnd 

    Set ns = GetNamespace("MAPI") 
    Set Inbox = ns.GetDefaultFolder(olFolderInbox) 
    Set SubFolder = Inbox.Folders("TEST") 
    Set Totalmsg = msg.ReceivedTime 
    oFrom = InputBox("Please give start time", ("Shadowserver report")) 
    oEnd = InputBox("Please give End time", ("Shadowserver report")) 

    If Totalmsg <= oFrom And Totalmsg >= oEnd Then 
    For Each msg In SubFolder.Items 
      For Each Atchmt In msg.Attachments 
        If (Right(Atchmt.FileName, 3) = "zip") Then 
        MsgBox "1" 

            FileNameFolder = "C:\Users\xxxx\Documents\test\" 
            FileName = FileNameFolder & Atchmt.FileName 
            Atchmt.SaveAsFile FileName 
            Set oApp = CreateObject("Shell.Application") 
            oApp.NameSpace(FileNameFolder).CopyHere oApp.NameSpace(FileName).Items 

            Kill (FileName) 
            On Error Resume Next 
            Set FSO = CreateObject("scripting.filesystemobject") 
            FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True 
        End If 
      Next 
    Next 
End If 
End Sub 

Answer 1

做了一些改进，以提高性能和清晰度：

1. 测试上的消息接收到的时间内环路
2. 定义相关的变量，如日期（如MsG.ReceivedTime）和改进的输入消息
3. 添加Option Explicit，以避免在未来的编码（很好的做法）的事故
4. 使用Environ$("USERPROFILE")获取用户目录的轻拍^ h
5. 改组变量初始化环
6. 新增LCase之外，以确保让所有拉链（包括.ZIP）

代码：

Option Explicit 

Sub Unzip() 
    '''Variables for the main functionality 
    Dim NS As NameSpace 
    Dim InboX As MAPIFolder 
    Dim SubFolder As MAPIFolder 
    Dim MsG As Outlook.MailItem 
    Dim AtcHmt As Attachment 
    Dim ReceivedHour As Date 
    Dim oFrom As Date 
    Dim oEnd As Date 
    '''Variables for unzipping 
    Dim FSO As Object 
    Dim ShellApp As Object 
    Set FSO = CreateObject("Scripting.FileSystemObject") 
    Set ShellApp = CreateObject("Shell.Application") 
    Dim FileNameFolder As Variant 
    Dim FileName As Variant 

    '''Define the Outlook folder you want to scan 
    Set NS = GetNamespace("MAPI") 
    Set InboX = NS.GetDefaultFolder(olFolderInbox) 
    Set SubFolder = InboX.Folders("TEST") 

    '''Define the folder where you want to save attachments 
    FileNameFolder = Environ$("USERPROFILE") & "\Documents\test\" 

    '''Define the hours in between which you want to apply the extraction 
    oFrom = CDate(InputBox("Please give Start time" & vbCrLf & _ 
          "Example: 9AM", ("Shadowserver report"), "9AM")) 
    oEnd = CDate(InputBox("Please give End time" & vbCrLf & _ 
          "Example: 6PM", ("Shadowserver report"), "6PM")) 

    For Each MsG In SubFolder.items 
     ReceivedHour = MsG.ReceivedTime 
     If oFrom <= TimeValue(ReceivedHour) And _ 
      TimeValue(ReceivedHour) <= oEnd Then 
      For Each AtcHmt In MsG.Attachments 
       FileName = AtcHmt.FileName 
       If LCase(Right(FileName, 3)) <> "zip" Then 
       Else 
        FileName = FileNameFolder & FileName 
        AtcHmt.SaveAsFile FileName 

        ShellApp.NameSpace(FileNameFolder).CopyHere _ 
          ShellApp.NameSpace(FileName).items 

        Kill (FileName) 
        On Error Resume Next 
        FSO.deletefolder Environ$("Temp") & "\Temporary Directory*", True 
       End If 
      Next AtcHmt 
     End If 
    Next MsG 
End Sub 

Answer 2

我只是要包括你需要改变的部分。其他线路将是相同的。基本上，你需要做的是在你的循环内设置Totalmsg每个msg;

Sub Unzip() 

'... copy your code till here 

Set SubFolder = Inbox.Folders("TEST") 
oFrom = InputBox("Please give start time", ("Shadowserver report")) 
oEnd = InputBox("Please give End time", ("Shadowserver report")) 


For Each msg In SubFolder.Items 
    Set Totalmsg = msg.ReceivedTime 
    If Totalmsg <= oFrom And Totalmsg >= oEnd Then 'You check it for each msg 

'rest will be the same until ... 

     FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True 
    End If 
    Next 
    End If 
Next 

End Sub