Send email to all contacts in Outlook address book when a new email received (VB)

Question

I want to write a VBA script that when Outlook receive a new email from a specific email address , the VBA script has to detect that and resend the new received email to all contacts in the address book .

For now i was able to send an email to all contacts in address book :

Sub SendEmails()
Dim ContactsFolder As Folder
Set ContactsFolder = Session.GetDefaultFolder(olFolderContacts)
Dim Contact As Object
Dim olApp As Outlook.Application
Dim objMail As Outlook.MailItem
Set olApp = Outlook.Application

For Each Contact In ContactsFolder.Items
    Set objMail = olApp.CreateItem(olMailItem)
    With objMail
        .Subject = "Subject of the received email"
        .Body = "Body of the received email"
        .To = Contact.Email1Address
        .Send
    End With
Next
End Sub

but how to use this script so it called when a new email received from a specific email address.

i tried to put this in ThisOulookSeassion to check for new message event so i could call my above code within it :

Private Sub Application_NewMail()
MsgBox "New mail"
End Sub

but it didn't work.

Also i tried this (i put it in ThisOulookSeassion too) :

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 
   ' ******************
   ' and placing my code here.
   ' ******************
   End If
 ProgramExit: 
  Exit Sub
 ErrorHandler: 
   MsgBox Err.Number & " - " & Err.Description 
  Resume ProgramExit 
 End Sub

but when i click run it ask me to create new macro and don't run the code.

Any suggestions ?

Answer 1

The simplest way is to create a rule in Outlook. Then you can assign an existing VBA macro to run when the rule is run. Typically a VBA sub should like the following one:

 Sub SendEmails(mail as MailItem)
   Dim ContactsFolder As Folder
   Set ContactsFolder = Session.GetDefaultFolder(olFolderContacts)
   Dim objMail as MailItem
   Dim Contact As Object

   For Each Contact In ContactsFolder.Items
      Set objMail = olApp.CreateItem(olMailItem)
      With objMail
        .Subject = mail.Subject
        .Body = "Body Text"
        .To = Contact.Email1Address
        .Send
      End With
   Next
 End Sub

Also you may consider adding recipients to the Recipients collection and set their Type to the olBCC value. Thus, each of them will recieve a separate email and you have to submit only a single mail item.