Open .msg file and add emails

[kabootar]

Hi,

I have a macro for opening a .msg file but I need to also add email addresses. The email addresses will be different depending on the project.

Is this possible?

The macro I currently have is:

Sub OpenOutlookMsg ()

Dim myoutapp As Object
Dim myitem A Object

Set myoutapp = CreateObject("Outlook.Application")
Set myitem = myoutapp.CreateItemFromTemplate("C:\Users\aa\Desktop\Project.msg")

myitem.Display

End sub

 

[John_w]

Try this to get started:

Public Sub Add_Email_Addresses_To_Outlook_Msg()

    Dim outApp As Object 'Outlook.Application
    Dim outEmail As Object 'Outlook.MailItem
    Dim outRecipient As Object 'Outlook.Recipient
    Dim newEmailAddresses As String, newEmailAddress As Variant
    
    newEmailAddresses = "email1@address.com,email2@address.com"
       
    On Error Resume Next
    Set outApp = GetObject(, "Outlook.Application")
    If outApp Is Nothing Then
        MsgBox "Outlook is not open"
        Exit Sub
    End If
    On Error GoTo 0

    'Open .msg file in Outlook 2003
    'Set outEmail = outApp.CreateItemFromTemplate("C:\Users\aa\Desktop\Project.msg")
    
    'Open .msg file in Outlook 2007+
    Set outEmail = outApp.Session.OpenSharedItem("C:\Users\aa\Desktop\Project.msg")
    
    For Each newEmailAddress In Split(newEmailAddresses, ",")
        outEmail.recipients.Add newEmailAddress
    Next

    outEmail.Save           'Save with existing file name
    'outEmail.SaveAs "C:\Users\aa\Desktop\NEW Project.msg"     'Or save with new folder and/or file name
    
End Sub

 

[kabootar]

That is perfect!

Just one thing - when I edit the email addresses it still gives me the above emails you entered.

How can I remove this?

 

[John_w]

Either manually recreate/save the original .msg file, or run this macro which removes the specified email addresses:

Public Sub Remove_Email_Addresses_From_Outlook_Msg()

    Dim outApp As Object 'Outlook.Application
    Dim outEmail As Object 'Outlook.MailItem
    Dim outRecipient As Object 'Outlook.Recipient
    Dim removeEmailAddresses As String, removeEmailAddress As Variant
    Dim i As Long
    
    removeEmailAddresses = "email1@address.com,email2@address.com"
       
    On Error Resume Next
    Set outApp = GetObject(, "Outlook.Application")
    If outApp Is Nothing Then
        MsgBox "Outlook is not open"
        Exit Sub
    End If
    On Error GoTo 0

    'Open .msg file in Outlook 2003
    'Set outEmail = outApp.CreateItemFromTemplate("C:\Users\aa\Desktop\Project.msg")
    
    'Open .msg file in Outlook 2007+
    Set outEmail = outApp.Session.OpenSharedItem("C:\Users\aa\Desktop\Project.msg")
        
    For Each removeEmailAddress In Split(removeEmailAddresses, ",")
        For i = outEmail.recipients.Count To 1 Step -1
            If InStr(1, outEmail.recipients(i), removeEmailAddress, vbTextCompare) Then
                outEmail.recipients.Remove i
            End If
        Next
    Next
    
    outEmail.Save           'Save with existing file name
    'outEmail.SaveAs "C:\Users\aa\Desktop\NEW Project.msg"     'Save with new file name
    
End Sub

 

[kabootar]

Perfect!

Thank You John_W!!!