Question

我有一个下面的代码，引发错误。我只需要获取今天收到的邮件（当前日期）。请帮忙解决这个问题。我的其他如果案件工作正常。除了Date（SentOn）。

我的脚本就像根据用户给定时间提取文件并创建合并工作表来获取电子邮件。我正在尝试获取当前日期收到的邮件。

Sub Unzip()
        Dim app As Object
        Dim NS As Object
        Dim InboX As Object
        Dim SubFolder As Object
        Dim MsG As Object
        Dim AtcHmt As Object
        Dim ReceivedHour As Date
        Dim oFrom As Date
        Dim oEnd As Date
        Dim f As Boolean
        '''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
        Dim Ldate As String
        Dim myitem As Object   
        Ldate 
        On Error Resume Next
        Set app = GetObject(Class:="Outlook.Application")
        If app Is Nothing Then
            Set app = CreateObject(Class:="Outlook.Application")
            f = True
        End If
        On Error GoTo ErrHandler
        Set NS = app.GetNamespace("MAPI")
        Set InboX = NS.GetDefaultFolder(6) ' olFolderInbox
        Set SubFolder = InboX.Folders("TEST")
        Set myitem = Outlook.mailitem
        FileNameFolder = Environ$("USERPROFILE") & "\Documents\test\"
        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
        If Ldate = DateValue(myitem.SentOn) Then
            MsG ("Yes")
            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
                        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
        End If
        Next MsG
    End Sub

Answer 1

不要遍历文件夹中的所有项目。使用Items.Find/FindNext或Items.Restrict以及[ReceivedTime]的限制在给定范围内。

Answer 2

嗨这就是我如何开始回答

Dim Ldate As String

    Ldate = Date

    '''Define the Outlook folder you want to scan
    On Error Resume Next
    Set app = GetObject(Class:="Outlook.Application")
    If app Is Nothing Then
        Set app = CreateObject(Class:="Outlook.Application")
        f = True
    End If
    On Error GoTo ErrHandler
    Set NS = app.GetNamespace("MAPI")
    Set InboX = NS.PickFolder
    'Set SubFolder = InboX.Folders("Shadow Server Reports")
    'Dim myitem As Outlook.MailItems
    '''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 InboX.Items
    If Ldate = DateValue(MsG.SentOn) Then
        ReceivedHour = MsG.ReceivedTime
        If oFrom <= TimeValue(ReceivedHour) And _
            TimeValue(ReceivedHour) <= oEnd Then
            For Each AtcHmt In MsG.Attachments

需要使用SentOn日期获取邮件

2 个答案: