Open .msg file and add emails

kabootar

New Member
Joined
Jan 15, 2019
Messages
9
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
 

Some videos you may like

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,218
Try this to get started:
Code:
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

New Member
Joined
Jan 15, 2019
Messages
9
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

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,218
Either manually recreate/save the original .msg file, or run this macro which removes the specified email addresses:

Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,096,065
Messages
5,448,187
Members
405,490
Latest member
Larry of Oz

This Week's Hot Topics

Top