Sub test()
    Dim Subject(), Sender(), ReceivedTime(), Result() As String
    Dim i, x, y As Integer
    Dim Application As Outlook.Application
    Dim myNamespace As NameSpace
    Dim myFolder As MAPIFolder
    Dim Folder As MAPIFolder
       
    Dim myItems As Outlook.Items
    Dim myItem As Object
    Dim myDestFolder As Outlook.Folder


    Const olFolderInbox = 6

    Set Application = New Outlook.Application
    Set objOutlook = CreateObject("Outlook.Application")
    Set myNamespace = objOutlook.GetNamespace("MAPI")
    Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)    '//收件夾子文件

    For y = 0 To myFolder.Folders.Count
        If (y = 0) Then
       
            Set myItems = myFolder.Items
       
        Else
            Set Folder = myFolder.Folders(y)
            Set myItems = Folder.Items
       
        End If
       
        Set myItem = myItems.Restrict("[ReceivedTime] > '" & Date & "'")  '搜寻今天邮件
        myItem.Sort "[ReceivedTime]", False    '使用接收时间排序
        Set myDestFolder = myFolder.Folders("RepeatMail") '移动至 Repeat Mail 资料夹
       
        'Set colItems = objFolder.Items

        'MsgBox Date & DateAdd("d", 1, Date)
         
        i = 0
        For Each objMessage In myItem
            ReDim Preserve Subject(i)
            ReDim Preserve Sender(i)
            ReDim Preserve ReceivedTime(i)
       
            Subject(i) = objMessage.Subject
            Sender(i) = objMessage.SenderEmailAddress
            ReceivedTime(i) = objMessage.ReceivedTime
            'Result(i) = objMessage.Subject & "-" & objMessage.SenderEmailAddress & "-" & objMessage.ReceivedTime
            'a(i) = objMessage.Subject
            'MsgBox objMessage.Subject
            i = i + 1
        Next


        If (i > 0) Then '判断是否有今天邮件
            x = 1
            ReDim Preserve Result(x)
            'Result(x) = Subject(0)
            For i = 1 To UBound(Subject)
                '判断跟前面的Array是否一样,一样就加入Result字串中
                If (Subject(i - 1) = Subject(i) And Sender(i - 1) = Sender(i)) Then
                    'MsgBox Subject(i)
                    ReDim Preserve Result(x)
                    Result(x) = Subject(i)
                    MsgBox Result(x)
                    '重複MAIL移動至 RepeatMail DataFile
                   
                    Set myItem = myItems.Find("[Subject] = '" & Result(x) & "'")

                   If (TypeName(myItem) <> "Nothing") Then
                    myItem.Move myDestFolder
                  
                 End If


                    x = x + 1
                End If

            Next
       
            Erase Subject(), Sender(), ReceivedTime(), Result()  '清除阵列内容
       
        End If

    Next

    End Sub
复制代码