Przenoszenie wiadomości do innego folderu z warunkami

Jeden z angielskojęzycznych użytkowników forum spytał czy jest możliwość utworzenia reguły dla poczty przychodzącej, która by przenosiła wiadomości z określonymi parametrami. Głównie chodziło o przeniesienie starszych wiadomości o określonej dacie, z folderu „Skrzynka odbiorcza” do folderu zdefiniowanego.

Poniżej znajduje się makro, które można wywołać z poziomu przycisku i działa dla każdego folderu, w którym zostanie wywołane. Opcjonalnie oprócz spełnionych wymagań dodano funkcję rozpoznania adresu nadawcy, którego proces miałby dotyczyć.

Poniższą funkcje sterującą procesem można rozszerzyć o wymaganie załączników konkretnej treści zawartej w temacie lub kontekście treści wiadomości, bądź dodając element wizualny, taki jak pasek postępu osadzony w formie.

Option Explicit On

Sub MoveMess2Folder()
    'opcjonalne można umieścić adres wysyłającego lub/i datę ograniczenia czasu utworzenia wiadomości
    Call MoveToFolder("VBATools", "vbatools@vbatools.pl", Now - 365)
End Sub

Function MoveToFolder(DestFolderName$, Optional MassageFrom$, Optional CreationTime As Date)
    'Machine by O'Shon
    Dim myOLApp As Application
    Dim myNameSpace As NameSpace
    Dim myInbox As MAPIFolder
    Dim objItem As MailItem
    Dim x&
    Dim oFolder As MAPIFolder
    Dim IoTask As Items

    If Application.ActiveExplorer.CurrentFolder.DefaultItemType <> 0 Then Exit Function
    myOLApp = CreateObject("Outlook.Application")
    myNameSpace = myOLApp.GetNamespace("MAPI")
    myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    IoTask = myInbox.Items
    oFolder = myOLApp.ActiveExplorer.CurrentFolder

    If Not FolderExists(myInbox, DestFolderName) Then
        MsgBox("Folder ''" & DestFolderName & "'' does not exist under ''" & myInbox & "'' folder" & _
            vbCr & "Create the folder ''" & DestFolderName & "'' or change VBACode.", vbExclamation, "VBATools.pl")
        Exit Function
    End If

    For x = IoTask.Count To 1 Step -1
        DoEvents()
        'W tym miejscu można pobrać i dodać wartość parametru do paska postępu
        If IoTask.item(x).Class = 43 Then
            objItem = IoTask.item(x)
            'Debug.Print objItem.SenderEmailAddress & " " & objItem.Subject
            If Len(CreationTime) > 0 And Len(MassageFrom) > 0 Then
                If objItem.SenderEmailAddress = MassageFrom And _
                Format(objItem.CreationTime, "Short Date") <= Format(CreationTime, "Short Date") Then _
                objItem.Move(myInbox.Folders(DestFolderName))
            ElseIf Len(MassageFrom) > 0 And Len(CreationTime) = 0 Then
                If objItem.SenderEmailAddress = MassageFrom Then _
                objItem.Move(myInbox.Folders(DestFolderName))
            ElseIf Len(CreationTime) > 0 And Len(MassageFrom) = 0 Then
                If Format(objItem.CreationTime, "Short Date") <= Format(CreationTime, "Short Date") Then _
                objItem.Move(myInbox.Folders(DestFolderName))
            Else
                objItem.Move(myInbox.Folders(DestFolderName))
            End If
        End If
    Next

    objItem = Nothing
    oFolder = Nothing
    IoTask = Nothing
    myOLApp = Nothing
    myNameSpace = Nothing
    myInbox = Nothing
    objItem = Nothing
End Function

Function FolderExists(ByVal parentFolder As MAPIFolder, ByVal DestFolderName As String)
    'Function code from www.outlookcode.com
    Dim tmpInbox As MAPIFolder
    On Error GoTo handleError
    tmpInbox = parentFolder.Folders(DestFolderName)
    FolderExists = True
    Exit Function
handleError:
    FolderExists = False
End Function

W przypadku braku doświadczenia w instalacji makr polecam artykuł Instalacja i uruchamianie makr.
 

Shon Oskar – www.VBATools.pl

© Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.