Option Explicit
Sub FinishMSG()
    'Кнопка "Отработано" из окна списка
    Dim ActiveMSG As Object
    Dim Item As MailItem
    Dim i&
    Dim oApp As New Outlook.Application
    Dim aFolderName As Outlook.Folder
    Dim NSpace As NameSpace
    Set NSpace = oApp.GetNamespace("MAPI")
    Set aFolderName = NSpace.Folders.Item(4).Folders.Item(2).Folders.Item("Отработан")
    Set ActiveMSG = Application.ActiveWindow.Selection
    Dim oAccount As Outlook.Account
    For Each oAccount In Application.Session.Accounts
        If oAccount.DisplayName = "my@mail.ru" Then
            'Debug.Print oAccount.DisplayName
            For i = 1 To ActiveMSG.Count
                Set Item = ActiveMSG.Item(i)
                If InStr(Item.To, "my@mail.ru") > 0 Or InStr(Item.CC, "my@mail.ru") > 0 Then
                    Item.Categories = ""
                    Item.FlagRequest = ""
                    Item.Save
                    Call SaveFile(Item)
                    'Debug.Print aFolderName.Name
                    Item.Move aFolderName
                End If
            Next
        End If
    Next
End Sub