VBA Tools

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

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