Я пытаюсь перенаправить новые электронные письма в Outlook из группы рассылки под названием «Служба поддержки» в подпапку в течение определенного времени. Я не думаю, что правила позволяют переадресовывать электронные письма в определенное время, поэтому я использую событие Application.NewEmail.
Мой код настроен прямо сейчас, чтобы он мог переадресовывать электронные письма с адреса электронной почты отправителя Exchange во вложенную папку. Однако мне нужно каким-то образом сделать то же самое с группой рассылки, и я не уверен, как извлечь информацию, необходимую для идентификации группы рассылки.
Вот мой код:
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal cusItem As Object)
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
Dim strAddress As String, strEntryId As String
Dim objAddressentry As Outlook.AddressEntry, objExchangeUser As Outlook.ExchangeUser
Dim objReply As Outlook.MailItem, objRecipient As Outlook.Recipient
Dim objDestFolder As Outlook.MAPIFolder
If TypeName(cusItem) = "MailItem" And cusItem.SenderEmailType = "EX" Then
On Error GoTo ErrorHandler
Set objReply = cusItem.Reply()
Set objRecipient = objReply.Recipients.Item(1)
strEntryId = objRecipient.EntryID
objReply.Close OlInspectorClose.olDiscard
Set objAddressentry = objNS.GetAddressEntryFromID(strEntryId)
Set objExchangeUser = objAddressentry.GetExchangeUser()
strAddress = objExchangeUser.PrimarySmtpAddress()
If strAddress = "jabach@example.com" And TimeValue(Now()) >= TimeValue("08:00:00 AM") And TimeValue(Now()) <= TimeValue("05:00:00 PM") Then
Set objDestFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("ryule")
cusItem.Move objDestFolder
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description & vbCrLf & "Click Ok to continue"
Resume ProgramExit
End Sub
Также есть некоторые проблемы с Application_Startup (), фактически не запускающим Outlook, поэтому у меня все эти переменные объявлены дважды.