VBATools

Jeden z angielskojęzycznych forumowiczów 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 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 adres rozpoznanie 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 wizualną stronę taką jak pasek postępu osadzony w formie.

Option Explicit

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)
    'MVP OShon from VBATools.pl
    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
    Set myOLApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOLApp.GetNamespace("MAPI")
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set IoTask = myInbox.Items
    Set 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
            Set 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

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

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

Jeśli nie ma się doświadczenia w instalacji makr polecam przeczytać artykuł Instalacja i uruchamianie makr.

(c) Shon Oskar – www.VBATools.pl