Script in rule to send to multiple emails found in message bo

[GregB]

I have used the many helpful threads in this forum and almost have my script working.

I receive an automated email from a system and want to grab all emails from a specific domain listed within the message body and forward the message to these addresses. The code below works but if I find 3 address matches it send 3 emails. If I use the second code listed I can get all the addresses in a string separated by semi-colons. But it does not like adding the string to the recipients list.

Sub First(Item As Outlook.MailItem)
 
     Dim Reg1 As RegExp
 
     Dim M1 As MatchCollection
 
     Dim M As Match
 
     
     Set Reg1 = New RegExp
 
      Dim strAlias As String
 
   
    With Reg1
 
      
        '.Pattern = "([a-z0-9.]*)@([a-z0-9.]*)"
         .Pattern = "([a-z0-9.]*)@candu.com"
 
         .Global = True
 
     End With
 
     If Reg1.test(Item.Body) Then
 
         Set M1 = Reg1.Execute(Item.Body)
 
         For Each M In M1
 
           strAlias = M '& ";" & strAlias
 
           'MsgBox "reg1: " & strAlias
           'Item.Subject = "Test"
           
            Set MyForward = Item.Forward
           
strSubj = Replace(MyForward.Subject, "FW: ", "")
 
    MyForward.Subject = strSubj
   
MyForward.Recipients.Add strAlias
  MyForward.Send
  'Item.Save
         Next




     End If

 'MsgBox "reg2: " & strAlias
 
 
End Sub

Code to try and send to all discovered addresses in one email.

Sub First(Item As Outlook.MailItem)
 
     Dim Reg1 As RegExp
 
     Dim M1 As MatchCollection
 
     Dim M As Match
 
     
     Set Reg1 = New RegExp
 
      Dim strAlias As String
 
   
    With Reg1
 
      
        '.Pattern = "([a-z0-9.]*)@([a-z0-9.]*)"
         .Pattern = "([a-z0-9.]*)@mydomain.com"
 
         .Global = True
 
     End With
 
     If Reg1.test(Item.Body) Then
 
         Set M1 = Reg1.Execute(Item.Body)
 
         For Each M In M1
 
           strAlias = M & ";" & strAlias
 
           'MsgBox "reg1: " & strAlias
           'Item.Subject = "Test"
           
          
  'Item.Save
         Next


 
     End If

 MsgBox "reg1: " & strAlias
 
  Set MyForward = Item.Forward
           
strSubj = Replace(MyForward.Subject, "FW: ", "")
 
    MyForward.Subject = strSubj
   
MyForward.Recipients.Add strAlias
  MyForward.Send
 
End Sub

I have tried code below but not sure I have it just right.


For i = 0 To UBound(Split(strAlias, ";"))
Set ToForward = MyForward.Recipients.Add(Split(strAlias, ";")(i))
ToForward.Type = ItemTo
Next i


Thanks

 

[Diane Poremsky]

What happens when you use the string? As long as it's semicolon delimited, it should work.

 

[GregB]

What happens when you use the string? As long as it's semicolon delimited, it should work.

Nothing..that is the strange part. I run the rule against an email and the Msgbox shows 3 addresses separated by semi-colon. I hit OK and nothing happens. If I paste the string into an email it works fine. Running the top script works no problem.

 

[Michael Bauer]

You could add the semicolon delimited string to the To property. Recipients.Add takes only one recipient at once.

 

[Diane Poremsky]

Try Michael's suggestion and change this
MyForward.Recipients.Add strAlias
to
MyForward.To strAlias

 

[GregB]

Try Michael's suggestion and change this
MyForward.Recipients.Add strAlias
to
MyForward.To strAlias

I will try that. A quick second. How do I add in a hyphen in the pattern for email address's?

 

[Diane Poremsky]

adding the dash after the . should work
"([a-z0-9.-]*)@([a-z0-9.]*)"

you might want to use this to cover all bases
"([a-z0-9._%+-]*)@([a-z0-9.-]*)"

 

[GregB]

That worked for the hyphen. Thank-you

The other is still not working.
Her is the code I am using

Sub First(Item As Outlook.MailItem)
 
     Dim Reg1 As RegExp
 
     Dim M1 As MatchCollection
 
     Dim M As Match
 
     
     Set Reg1 = New RegExp
 
      Dim strAlias As String
 
   
    With Reg1
 
      
        '.Pattern = "([a-z0-9.]*)@([a-z0-9.]*)"
         .Pattern = "([a-zA-Z0-9.]*)@mydomain.com"   'find all  email addreses within email
 
         .Global = True
 
     End With
 
     If Reg1.test(Item.Body) Then
 
         Set M1 = Reg1.Execute(Item.Body)
 
         For Each M In M1
 
          strAlias = M & ";" & strAlias
 
           'MsgBox "reg1: " & strAlias
         
           
         
        Next


    End If
 
Set MyForward = Item.Forward
           
    strSubj = Replace(MyForward.Subject, "FW: ", "") ' Remove the FW from the subject
 
    MyForward.Subject = strSubj
   
    MsgBox "reg1: " & strAlias ' this shows recipient.first@mydomain.com;recipient.second@mydomain.com;recipient.third@mydomain.com;
   
    MyForward.To strAlias
 
'delete the top lines of the Forward message
strRemove = Left(MyForward.HTMLBody, InStr(1, MyForward.HTMLBody, "Message to user") + Len("Subject:") + Len(MyForward.Subject) + 25)
  MyForward.HTMLBody = Replace(MyForward.HTMLBody, strRemove, "")
 
  MyForward.Send


End Sub

 

[Diane Poremsky]

I'm getting an error on myforward.to, but using recipients.add works - but it takes a few seconds for the addresses to resolve.

will the messages be html or plain text? html adds each address twice as it reads the html code. you can use an if to trap dupe:

For Each M In M1
If Not M = strAlias Then
strAlias = M
myforward.Recipients.Add strAlias
End If



This works... it needs tidied up a bit.

Sub First(Item As Outlook.MailItem)
     Dim Reg1 As RegExp
     Dim M1 As MatchCollection
     Dim M As Match
     Dim myforward As MailItem
     Dim objRecip As Recipient
   
     Set Reg1 = New RegExp
      Dim strAlias As String
    
Set myforward = Item.Forward

     With Reg1
         .Pattern = "([a-z0-9.]*)@([a-z0-9.]*)"
        ' .Pattern = "([a-zA-Z0-9.]*)@mydomain.com"   'find all  email addreses within email
         .Global = True
     End With
     If Reg1.test(Item.Body) Then
         Set M1 = Reg1.Execute(Item.Body)
         For Each M In M1
          strAlias = M
              myforward.Recipients.Add strAlias
         Next
     End If
 
With myforward
   
strSubj = Replace(myforward.Subject, "FW: ", "") ' Remove the FW from the subject
   .Subject = strSubj

'delete the top lines of the Forward message
strRemove = Left(.Body, InStr(1, .Body, "Message to user") + Len("Subject:") + Len(.Subject) + 25)
  .HTMLBody = Replace(.HTMLBody, strRemove, "")
' .Display
End With

For Each objRecip In myforward.Recipients
objRecip.Resolve
Next

myforward.Send

     Set Reg1 = Nothing
     Set myforward = Nothing
    
End Sub

 

[Diane Poremsky]

BTW, if you want to resolve the addresses as you add them, use this instead of the one before the send.
If Not M = strAlias Then
strAlias = M
Set objRecip = myforward.Recipients.Add(strAlias)
objRecip.Type = olTo
objRecip.Resolve
End If

 

[GregB]

Thank you very much it is all working.

 

[GregB]

BTW, if you want to resolve the addresses as you add them, use this instead of the one before the send.
If Not M = strAlias Then
strAlias = M
Set objRecip = myforward.Recipients.Add(strAlias)
objRecip.Type = olTo
objRecip.Resolve
End If

I am having a strange issue. Every once in a while the script pops up an error to the effect that a message must have a to:. cc or bcc in the message. I have see somewhere code to check for this and send to a specific address (if you can point out the link that would be great).

More importantly it seems that if this happens and the user logged in is not around someone else logs into the machine to try and fix. Regardless when the original account logs in the script will no longer run. I try to manually run but a quick flash of a message happens and nothing. It seems something is corrupt in the profile? to fix before I have to get a new user to log into PC to have the script run as them. very frustrating. any ideas? Thanks