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

How to get Outlook Email received time

提问by kf dhivya

I need to extract attachments from Emails received in a user preferred time frame.

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

Say like extract for Emails received between 2PM to 4PM.

对下午 2 点到 4 点之间收到的电子邮件说喜欢摘录。

Please find the below code I've that extract files perfectly - but it did for all the Emails in the folder.

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

Please help me to resolve it.

请帮我解决它。

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

回答by R3uK

Made a few improvements to improve performance and clarity :

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

1. Test received time inside the loop on the messages
2. Defined related variables as Date (like MsG.ReceivedTime) and improved input messages
3. Added Option Explicitto avoid mishaps in future coding (VERY GOOD PRACTICE)
4. Use Environ$("USERPROFILE")to get User directory's path
5. Reorganize variables and initialisation outside of the loops
6. Added LCaseto be sure to get all zips (including .ZIP)

1. 测试消息循环内的接收时间
2. 将相关变量定义为日期（如MsG.ReceivedTime）和改进的输入消息
3. 添加Option Explicit以避免将来编码中的意外（非常好的做法）
4. 使用Environ$("USERPROFILE")让用户目录的路径
5. 在循环外重新组织变量和初始化
6. 添加LCase以确保获取所有 zip（包括.ZIP）

Code :

代码 ：

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

回答by M--

I am just going to include the part that you need to change. Other lines will be the same. Basically, what you need to do is to set the Totalmsginside your loop for each msg;

我只是将包括您需要更改的部分。其他线路将相同。基本上，您需要做的是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