Question

我正在努力实现的目标：

我突出显示我要删除的邮件
For循环在我突出显示的每个邮件项目上运行其余部分 - 所以剩下的就是为每个选定的单个对象完成了
宏拉出主题行中的特定文本以决定将邮件移动到哪个文件夹（这已经有效）
创建（如果需要），然后设置项目将移动到的文件夹。（已经有效）
这是我的问题所在 - 我可以将其设置为处理每个邮件项目并且工作正常（它可以对50个突出显示的邮件进行排序），或者对多个项目进行一次会话。我已经让它与调整工作。但是我不能让它与两者一起工作，无论是/或。
突出显示下一个项目或对话。现在，“联合代码”适用于单个邮件项目，但会话留在以前的邮件仍然在收件箱中。

到目前为止，这是我的代码：

Sub MoveToFiledAUTO2()
    On Error Resume Next

    Dim ns As Outlook.Namespace
    Dim moveToFolder As Outlook.MAPIFolder
    Dim objItem As Object
    Dim Myvalue As String
    Dim myFolder As Outlook.folder
    Dim myNewFolder As Outlook.folder
    Set ns = Application.GetNamespace("MAPI")
    Dim vSplit As Variant
    Dim sWord As Variant
    Dim minisplit As Variant
    Dim objSelection As Outlook.Selection
    Dim IsMessage As Integer

    Set myFolder = ns.Folders("Current Projects").Folders("BU")
    Set objSelection = Outlook.Application.ActiveExplorer.Selection

    For Each objItem In objSelection
        If TypeOf objItem Is MailItem Then
            subby = objItem.Subject
            vSplit = Split(subby)
            For Each sWord In vSplit
                If Left$(sWord, 1) = "8" And Len(sWord) = 6 Then
                    Myvalue = Left$(sWord, 6)
                    Exit For
                ElseIf Left$(sWord, 2) = "#8" And Len(sWord) = 7 Then
                    Myvalue = Mid$(sWord, 2, 6)
                    Exit For
                ElseIf Left$(sWord, 4) = "BU#8" And Len(sWord) = 9 Then
                    Myvalue = Mid$(sWord, 4, 6)
                    Exit For
                ElseIf Left$(sWord, 3) = "U#8" And Len(sWord) = 8 Then
                    Myvalue = Mid$(sWord, 3, 6)
                    Exit For
                ElseIf Left$(sWord, 3) = "BU8" And Len(sWord) = 8 Then
                    Myvalue = Mid$(sWord, 3, 6)
                    Exit For
                ElseIf Left$(sWord, 1) = "8" And Len(sWord) = 7 Then
                    Myvalue = Left$(sWord, 6)
                    Exit For
                Else
                End If
            Next
            Set Conversations = ActiveExplorer.Selection.GetSelection(Outlook.OlSelectionContents.olConversationHeaders)
            IsMessage = 0
            Set myNewFolder = myFolder.Folders.Add(Myvalue)
            Set moveToFolder = ns.Folders("Current Projects").Folders("BU").Folders(Myvalue)
            If moveToFolder Is Nothing Then
                MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
            End If
            For Each Msg In ActiveExplorer.Selection
                If moveToFolder.DefaultItemType = olMailItem Then
                    If objItem.Class = olMail Then
                        objItem.UnRead = False
                        objItem.FlagStatus = olNoFlag
                        objItem.Move moveToFolder
                        objItem.Categories = ""
                        objItem.Save
                        IsMessage = 1
                    End If
                End If
            Next Msg
            If IsMessage = 0 Then
                For Each Header In Conversations
                   Set Items = Header.GetItems()
                   For i = 1 To Items.Count
                       Items(i).UnRead = False
                       Items(i).Move moveToFolder
                       Items(i).FlagStatus = olNoFlag
                       Items(i).Categories = ""
                       Items(i).Save
                   Next i
                Next Header
            End If

        End If
    Next

    Set objItem = Nothing
    Set moveToFolder = Nothing
    Set ns = Nothing
    Set myFolder = Nothing
End Sub

Outlook VBA自动移动邮件或会话问题

0 个答案: