VBATools

Przeniesienie wiadomości do innego folderu gdy nadawca jest na liście dystrybucyjnej

by on Nov.28, 2011, under Outlook, Porady

Chciałbym przenieść wiadomość otrzymaną od osoby, która znajduje się na mojej liście dystrybucyjnej.

Podchodząc do zagadnienia z pozycji możliwości interfejsu MS Outlook, mamy możliwość jedynie określić regułę po konkretnie wskazanym adresie email co załatwiło by sprawę. Co gdy mamy wiele list dystrybucyjnych a każda z nich zawiera kilkadziesiąt/kilkaset odbiorców. Reguła taka nie była by możliwa do skonstruowania, ze względu na limit i czasochłonność przedsięwzięcia.

Jedyną opcją jest kod VBA, który pobierze adres wiadomości i sprawdzi względem wszystkich lub sprecyzowanej listy dystrybucyjnej, zgodność adresu z jej członkami. W przypadku, kiedy zgodność zostaje potwierdzona to wiadomość ta przenoszona jest do zadeklarowanego folderu.

Private WithEvents oInboxItems As Items

Private Sub Application_Startup()
 On Error Resume Next
 Set oInboxItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub oInboxItems_ItemAdd(ByVal Item As Object)
'MVP OShon from VBATools.pl
 Dim oDistList As DistListItem, DlItem, nIndex&, lItem As MailItem
 Set lItem = Item: If lItem Is Nothing Then Exit Sub

 Dim oKonFolder As MAPIFolder
 Set oKonFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)

 For Each DlItem In oKonFolder.Items
   DoEvents
   If DlItem.Class = 69 Then
    Set oDistList = DlItem
    If oDistList.DLName <> "NameOfSpecDisList" Then GoTo nastepny 'specified distlist not required
      For nIndex = 1 To oDistList.MemberCount
        If LCase(oDistList.GetMember(nIndex).Address) = LCase(lItem.SenderEmailAddress) Then
          lItem.Move Application.GetNamespace("MAPI").Folders("Foldery osobiste").Folders("testowy")
         '.Folders("Foldery osobiste") = my Personal folders
         '.Folders("testowy") = my subfolder to which me're moving message
          Exit Sub
        End If
      Next nIndex
nastepny:
    End If
 Next

 Set oDistList = Nothing
 Set lItem = Nothing
 Set oKonFolder = Nothing
End Sub

Sub Test()
 'MVP OShon from VBATools.pl
 Dim oMail  As MailItem
 On Error GoTo koniec
 Select Case TypeName(Application.ActiveWindow)
   Case "Explorer":  Set oMail = ActiveExplorer.Selection.Item(1)
   Case "Inspector": Set oMail = ActiveInspector.CurrentItem
   Case Else: Exit Sub
 End Select
 Call aaa(oMail) 'zmieniamy nawę procedury oInboxItems_ItemAdd na aaa
 Exit Sub
koniec:
 MsgBox Err.Number & " " & Err.Description, vbExclamation, "VBATools.pl"
End Sub

Można w procedurze umieścić wiele list dystrybucyjnych oraz wiele folderów, do których wiadomości będą przekierowane. Należy zastosować konstrukcję Select Case

Powyższą procedurę należy umieścić w klasie ThisOutlookSession i poddać modyfikacji skorygowania nazwy listy dystrybucyjnej (bądź jej wyeliminowaniu, dla sprawdzenia względem występowania we wszystkich listach) i poprawy nazwy folderów, do których wiadomość przychodząca ma być przeniesiona.

Polecam procedury poruszające kwestie list dystrybucyjnych  Tworzenie listy dystrybucyjnej dla podanych adresów email oraz Tworzenie listy dystrybucyjnej na podstawie adresów z zaznaczonych wiadomości email

 

(c) 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.
:, , ,

Leave a Reply