Microsoft Outlook troubleshooting

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

Sub MoveMess2Folder()
'opcjonalne mozna umieścic 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
    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

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

MVP Shon Oskar – VBATools.pl
Jeśli masz pytania dot. tego artykułu zapraszam na Forum
Skonfiguruj swój pakiet dodatków do Excela, Worda, PowerPointa i Outlooka



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

Komentarze

Komentarze
Artur
Artur 2015-03-26 06:59:24
w Outlook 2013 działa tylko na katalog "Skrzynka Odbiorcza" jak chce przenieść maile z innego katalogu to niestety nie działa.