Przeniesienie wiadomości do innego folderu gdy nadawca jest na liście dystrybucyjnej
by vbatools 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.