Как установить ссылку на нестандартную папку (для отправки почты при добавлении новой почты в папку)?

Question

Я хотел бы отправить письмо на разные почтовые адреса группы, когда новое письмо перетаскивается в соответствующую папку.

Если кто-то перетаскивает письмо в SubFolderTeam1, письмо будет отправлено в MailTeam1.

То же самое, когда мы перетаскиваем письмо в SubFolderTeam2, письмо будет отправлено в MailTeam2.

Структура моей папки:

• Входящие
• Родительская папка:
  • SubFolderTeam1
  • SubFolderTeam2

Почтовые адреса группы:

• MailTeam1
• MailTeam2

Родительская папка, содержащая подпапки, находится на том же уровне, что и папка по умолчанию «Входящие».

Я пробовал что-то, основанное на ответах на этот вопрос: Как запустить макрос после получения новой почты в Outlook?

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")
  ' default local Inbox
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)

  On Error GoTo ErrorHandler
  Dim Msg As Outlook.MailItem
  If TypeName(item) = "MailItem" Then
    Set Msg = item
    ' ******************
    
    'do the magic please
    
    ' ******************
  End If
ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

Комбинировано как показано ниже.

Sub Send_Emails()

  Dim OutlookApp As Outlook.Application
  Dim OutlookMail As Outlook.MailItem

  Set OutlookApp = New Outlook.Application
  Set OutlookMail = OutlookApp.CreateItem(olMailItem)
  
  With OutlookMail
    .BodyFormat = olFormatHTML
    .Display
    .HTMLBody = "Dear Team1" & "<br>" & "<br>" & "Please do you job. Thanks" & .HTMLBody
    .To = "MailTeam1@gmail.com"
    .Subject = "Test Subject"
    .Send
  End With

End Sub

Я попытался вставить вторую структуру кода в первые т один. Я пробовал запускать их отдельно: первый код на модуле класса, второй на модуле classi c. И еще несколько вещей, которые не имеют реального смысла в нашем измерении.

Answer 1

Вы можете начать с папки по умолчанию, а затем перейти к соответствующим папкам. Вам понадобится код ItemAdd для каждой папки.

Код находится в модуле ThisOutlookSession.

Option Explicit

Private WithEvents Items1 As items
Private WithEvents Items2 As items

Private Sub Application_Startup()

    Dim objNS As Namespace
    Set objNS = GetNamespace("MAPI")
    
    Dim inBox As folder
    Dim mailBox As folder
    
    Dim firstLevelFldr As folder
    Dim secondLevelFldr As folder
    
    Set inBox = objNS.GetDefaultFolder(olFolderInbox)
    
    Set mailBox = inBox.Parent
    'Debug.Print mailBox
    
    Set firstLevelFldr = mailBox.folders("Parent Folder")
    'Debug.Print firstLevelFldr
    
    Set secondLevelFldr = firstLevelFldr.folders("SubFolderTeam1")
    'Debug.Print secondLevelFldr
    Set Items1 = secondLevelFldr.items
    
    Set secondLevelFldr = firstLevelFldr.folders("SubFolderTeam2")
    'Debug.Print secondLevelFldr
    Set Items2 = secondLevelFldr.items
    
End Sub


Private Sub Items1_ItemAdd(ByVal item As Object)
    
    Dim OutlookMail As mailItem
    
    If TypeName(item) = "MailItem" Then
    
        Set OutlookMail = CreateItem(olMailItem)
  
        With OutlookMail
            .BodyFormat = olFormatHTML
            .Display
            .HTMLBody = "Dear Team1" & "<br>" & "<br>" & "Please do you job. Thanks" & .HTMLBody
            .To = "MailTeam1@gmail.com"
            .Subject = "Test Subject"
            .Send
        End With
  
    End If
  
End Sub


Private Sub Items2_ItemAdd(ByVal item As Object)
    
    Dim OutlookMail As mailItem
    
    If TypeName(item) = "MailItem" Then
    
        Set OutlookMail = CreateItem(olMailItem)
        
        With OutlookMail
            .BodyFormat = olFormatHTML
            .Display
            .HTMLBody = "Dear Team2" & "<br>" & "<br>" & "Please do you job. Thanks" & .HTMLBody
            .To = "MailTeam2@gmail.com"
            .Subject = "Test Subject"
            .Send
        End With
  
    End If
  
End Sub

Answer 2

Нет необходимости создавать новый экземпляр Outlook Application для отправки писем:

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")
  ' default local Inbox
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)

  On Error GoTo ErrorHandler
  Dim Msg As Outlook.MailItem
  If TypeName(item) = "MailItem" Then
    Set Msg = item
    ' ******************
    
    'do the magic please
    
    ' ******************
    Send_Emails
  
  End If
ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

Sub Send_Emails()

  Set OutlookMail = Application.CreateItem(olMailItem)
  
  With OutlookMail
    .BodyFormat = olFormatHTML
    .Display
    .HTMLBody = "Dear Team1" & "<br>" & "<br>" & "Please do you job. Thanks" & .HTMLBody
    .To = "MailTeam1@gmail.com"
    .Subject = "Test Subject"
    .Send
  End With

End Sub