• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

How to open and edit existing email

ThrottleWorks

Excel Ninja
Hi
I need help for editing and existing e-mail saved on a drive.
Please see below details for your reference.

User have saved an e-mail at his drive.
We have an Excel macro.
Path of this email is saved in a cell in the macro.
Macro needs to open the e-mail on the base of path mentioned in the cell.
Once opened, macro needs add 3,4 text lines in the e-mail body.
These lines are saved in the macro itself in a worksheet.
Below these lines, macro needs paste a range copied from another worksheet of the macro.
So lines will be something like, hi, please find attached, review, in that sense.
Below these lines and Excel range, let us say A1:C50 with the its formatting.

I am able to open the email, write simple HTML based text line in the body.
However am not able to paste the ranges in existing email.
Can anyone please help me in this.

This is the basic code I am using to open the email.

Code:
Sub OpenEmail()
    Call DefineWorksheets
    Dim olApp As Object
    Dim olMail As Object
    Dim strPath As String
    
    strPath = Sht_TMPLT.Range("D34").Value
    
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItemFromTemplate(strPath)
    
    olMail.Display
    
    Set olMail = Nothing
    Set olApp = Nothing
End Sub
 
I tried with below code. However it is creating a new e-mail. I want to edit the existing e-mail.

Code:
Sub OpenEmail()
    Call DefineWorksheets
    Dim olApp As Object
    Dim olMail As Object
    Dim olInsp As Object
    Dim olDoc As Object
    Dim strPath As String
    Dim strTo As String
    Dim strCC As String
    Dim strSubject As String
    Dim strHTML As String
    Dim rng As Range
    
    strPath = Sht_TMPLT.Range("D34").Value
    
    Set rng = Nothing
    On Error Resume Next
    Set rng = Sht_TMPLT.Range("A1:B5")
    On Error GoTo 0
    
    strTo = Sht_Email.Range("B1").Value
    strCC = Sht_Email.Range("B1").Value
    strSubject = Sht_Email.Range("B1").Value
    
    Dim StrBody1 As String
    StrBody1 = "Dear All," & "<br><br>" & "This is confidential." & "<br><br><br>"

    
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItemFromTemplate(strPath)
    
    On Error Resume Next
        With olMail
            .To = "xxxx"
            .CC = "xxxx"
            .BCC = "xxxx"
            .Subject = "This is confidential" & dt_formatted2
            .HTMLBody = StrBody1 & RangetoHTML(rng)
            .Display
    End With
    On Error GoTo 0
    
    olMail.To = strTo
    olMail.CC = strCC
    olMail.Subject = strSubject
    
    olMail.Display
    Set olInsp = olMail.GetInspector
    Set olDoc = olInsp.WordEditor
    
    olDoc.Range(olDoc.Content.End - 1, olDoc.Content.End - 1).InsertAfter strHTML
End Sub
Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")

    TempWB.Close savechanges:=False

    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
Tried another version, it is opening existing e-mail, however facing bug at olInsp.WordEditor.Range.Paste
It is saying, word has encountered a problem.

Code:
Sub OpenEmailWithPath()
    Call DefineWorksheets
    'Define variables
    Dim olApp As Object
    Dim olNs As Object
    Dim olMail As Object
    Dim olInsp As Object
    Dim strPath As String
    Dim strTo As String
    Dim strCC As String
    Dim strSubject As String
    Dim rng As Range
    
    'Set email path from Excel cell
    strPath = Sht_TMPLT.Range("D34").Value
    
    'Create Outlook objects
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    
    'Open email
    Set olMail = olApp.CreateItemFromTemplate(strPath)
    olMail.Display
    
    'Add To, CC, and Subject fields
    strTo = "example1@example.com"
    strCC = "example2@example.com"
    strSubject = "Example Email Subject"
    With olMail
        .To = strTo
        .CC = strCC
        .Subject = strSubject
    End With
    
    'Add HTML lines to email body
    Dim strHTML As String
    strHTML = "<html><body><p>Sample HTML line 1</p><p>Sample HTML line 2</p><p>Sample HTML line 3</p><p>Sample HTML line 4</p><p>Sample HTML line 5</p></body></html>"
    
    'Add range below HTML lines in email body
    Set rng = Sht_TMPLT.Range("B2:D5") 'Change range as per your requirement
    rng.Copy
    Set olInsp = olMail.GetInspector
    olInsp.WordEditor.Range.InsertAfter vbCrLf & strHTML
    olInsp.WordEditor.Range.InsertAfter vbCrLf
    olInsp.WordEditor.Range.Paste 'bug at this line
End Sub
 
All of those codes use the exact same method to create the email, which is using the saved email as a template to create a new email.
 
Hi @Debaser , thanks for the help. I am able to resolve this. I do not want to create new e-mail. I want to edit the existing e-mail.
Could you please help me if you get time.
Have a nice day ahead. :)
 
Hi,

I tried using below code. It is editing existing e-mail, however facing some issues with HTML body and formatting.
</p><p> is getting added to e-mail body.
Also, this code is pasting excel range as picture, I need to get the excel range as it is, it should be editable.

Code:
Sub OpenEmailWithRange()
    Call DefineWorksheets
   
    Dim rng As Range
    Dim olInsp As Object
    Dim olDoc As Object
    Dim olRange As Object
    Dim emailPath As String
    Dim olApp As Object
    Dim olMail As Object
    Dim strHTML As String
   
    emailPath = Sht_TMPLT.Range("D34").Value
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItemFromTemplate(emailPath)
   
    olMail.To = "recipient@example.com"
    olMail.CC = "cc@example.com"
    olMail.Subject = "Email Subject"
   
    strHTML = "<p>Sample HTML line 1</p>"
    strHTML = strHTML & "<p>Sample HTML line 2</p>"
    strHTML = strHTML & "<p>Sample HTML line 3</p>"
    strHTML = strHTML & "<p>Sample HTML line 4</p>"
    strHTML = strHTML & "<p>Sample HTML line 5</p>"
   
    Set olInsp = olMail.GetInspector
    Set olDoc = olInsp.WordEditor
    Set olRange = olDoc.Range
    olRange.Collapse 1
    olRange.InsertAfter (strHTML)
   
    olRange.InsertParagraphBefore
    olRange.InsertParagraphBefore
   
   
    Set rng = Sht_TMPLT.Range("B2:D5")
    rng.CopyPicture xlScreen, xlBitmap
   
    olRange.Collapse 0
    olRange.PasteSpecial DataType:=wdPasteBitmap
   
    olRange.InsertParagraphAfter
    olRange.InsertParagraphAfter
   
    olRange.Find.Execute FindText:="<o:p></o:p>", ReplaceWith:="", Replace:=2
    olRange.Find.Execute FindText:="<p>&nbsp;</p>", ReplaceWith:="", Replace:=2
    olRange.Find.Execute FindText:="<html><body>", ReplaceWith:="", Replace:=2
    olRange.Find.Execute FindText:="</body></html>", ReplaceWith:="", Replace:=2
   
    olMail.Display
End Sub
 
I tried using below code. It is editing existing e-mail,

No, it isn't. It's doing the same as all the other codes you posted, namely creating a new email using the existing one as a template. I don't really see why that matters to you though?

I'm not sure what you mean by an editable range? You can't embed an excel range in an email. The nearest thing would be creating an HTML table but I'm not sure why you want people to be able to edit data in an email that you sent to them.
 
Hi @Debaser sorry for late reply. Below code is editing existing e-mail. Please see if you get time.
Ideas is to, open an existing ongoing issue for the item and reply to that item, that is why need to edit existing email only and not create new one.
Now with this code, we are able to copy the excel range as it is and not as a picture.

Facing only one issue here, email is trying to be sent as on-behalf, am trying to resolve that issue.
on-behalf name is appearing as the person who sent existing e-mail.

Thanks for your time and help.
Have a nice day ahead. :)
 
Last edited:
Hi,
The only only issue am facing is, email is trying to be sent as on-behalf, am trying to resolve that issue.
on-behalf name is appearing as the person who sent existing e-mail.
Used below lines but still not helping.

Code:
olMail.SentOnBehalfOfName = ""
olMail.Display
 
Last edited by a moderator:
Hi,
Can anyone please help me in this.
I am using below code lines to edit .SentOnBehalfOfName still previous sender's name is reflecting on e-mail.
I am required to manually select the user (i.e. my name). Not able to understand how do I resolve this.

Code:
'
 Display the email
    Dim OL As Object, olAllUsers As Object, oExchUser As Object, oentry As Object, myitem As Object
    Dim User As String
    Set OL = CreateObject("outlook.application")
    Set olAllUsers = OL.Session.AddressLists.Item("All Users").AddressEntries
    User = OL.Session.CurrentUser.name
    Set oentry = olAllUsers.Item(User)
    Set oExchUser = oentry.GetExchangeUser()
    
    olMail.SentOnBehalfOfName = oExchUser
 
Try:

Code:
    Set olMail.Sender = olApp.session.currentuser.addressentry

First, my apologies for late reply, I was away due to some emergency hence could not reply on time.
This code line is working great, thanks a lot for the help. Was not able to resolve it on my own for 3-4 days.
Have a nice day ahead. :)
 
Hi,
Am facing two issues with this code.
E-mail signature is getting created at the very bottom of the previous e-mail.
For example, am the user and if e-mail sent by ABC and macro is editing that e-mail, so my e-mail sign is getting created at the bottom of ABC's e-mail.

In short, it is not doing proper 'reply', code is only editing the e-mail body, that is why not able to see below lines in the email.
Can anyone help me in this please.
 
Last edited:
Hi,
Am using below code. Only issue is with the default outlook e-mail signature. Macro not able to populate default e-mail signature.
Can anyone please help me in this.

Code:
Sub OpenEmailWithRange()
    Call DefineWorksheets
    Dim OlApp As Object
    Dim olNS As Object
    Dim olMail As Object
    Dim olReply As Object
    Dim strFilePath As String
    Dim StrSignature As String
    Dim MyFileName As String
    Dim emailPath As String
    Dim FilePath As String
    Dim olInsp As Object
 
    'Set the file path for the email message
    strFilePath = Sheets("DummyName").Range("D37").Value
 
    'Create Outlook application object
    Set OlApp = CreateObject("Outlook.Application")
 
    'Create Namespace object
    Set olNS = OlApp.GetNamespace("MAPI")
 
    'Open the email message
    Set olMail = olNS.OpenSharedItem(strFilePath)
 
    'Create a reply to all
    Set olReply = olMail.ReplyAll
 
    'Set the subject and To fields of the reply email to match the original email
    olReply.Subject = olMail.Subject
    olReply.To = olMail.To
 
    'Set the recipient, CC, and subject of the email
    olReply.To = Sht_Email.Range("B1").Value2
    olReply.Cc = Sht_Email.Range("B2").Value2
    Sht_Email.Range("B4").Value2 = olReply.Subject
    olReply.Subject = Replace(olReply.Subject, "FW:", "RE:", , , vbTextCompare) & " - " & Sht_TMPLT.Range("D4")
 
    MyFileName = "ABCD_" & Sht_Map.Range("I2").Value2 & ".xlsb"
    FilePath = ThisWorkbook.path & "\" & MyFileName
    ActiveWorkbook.SaveAs Filename:=FilePath, FileFormat:=50, CreateBackup:=False
 
    'Add the saved workbook as an attachment to the email
    If olReply.Attachments.Count > 0 Then
        For i = olReply.Attachments.Count To 1 Step -1
            olReply.Attachments.Item(i).Delete
        Next i
    End If
    olReply.Attachments.Add FilePath
 
    'Add the email signature to the reply email
    StrSignature = OlApp.CreateItem(0).HTMLBody
    olReply.HTMLBody = "<span style='font-family: Calibri; font-size: 10pt;'>aaa,<br><br>" & _
                       "aaaaa<br><br>" & _
                       "aaaaa</span><br><br>" & _
                       Replace(olReply.HTMLBody, "aaaa<br><br><br>", "")
 
    'Copy the Excel range
    Dim rng As Range
'''    Set rng = Sht_Email.Range("I1:K5")
 
    If Sht_TMPLT.Range("D2") = "Single" Then
        ' Copy a range from the TMPLT sheet and paste it as a bitmap into the email
        lastRow = Sht_Email.Range("$I65000").End(xlUp).Row
        Set rng = Sht_Email.Range("I1:N" & lastRow)
     
        Sht_Email.Columns("I:M").AutoFit
        Sht_Email.Columns("J:J").ColumnWidth = 35
        Sht_Email.Range("I1:N" & lastRow).Rows.AutoFit
        rng.Copy
    End If
 
    'Create a new Word document and paste the range
    Dim wdDoc As Object
    Dim wdRange As Object
 
    Set olInsp = olReply.GetInspector
 
    If Not olInsp Is Nothing Then
        Set wdDoc = olInsp.WordEditor
        Set wdRange = wdDoc.Range
     
        wdRange.Find.Execute "aawwsww", , , , , , True
        wdRange.Collapse 0
        wdRange.InsertAfter "<br><br>"
        wdRange.Collapse 0
        If Sht_TMPLT.Range("D2") = "Single" Then
            wdRange.PasteExcelTable False, False, False
        End If
        wdRange.InsertAfter "<br><br>"
    End If
 
    ' Remove unwanted HTML tags from the email
    wdRange.Find.Execute FindText:="<o:p></o:p>", ReplaceWith:="", Replace:=2
    wdRange.Find.Execute FindText:="<p>&nbsp;</p>", ReplaceWith:="", Replace:=2
    wdRange.Find.Execute FindText:="<p>", ReplaceWith:="", Replace:=2
    wdRange.Find.Execute FindText:="<br><br>", ReplaceWith:="", Replace:=2
 
    ' Replace any remaining "<br>" tags with line breaks
    wdRange.Find.Execute FindText:="<br>", ReplaceWith:=vbCr, Replace:=2

    'Display the reply email
    olReply.Display
 
    'Clean up objects
    Set olReply = Nothing
    Set olMail = Nothing
    Set olNS = Nothing
    Set OlApp = Nothing
End Sub
 
Last edited:
Your issue isn't really clear to me. You have said both that your signature is getting added and that it isn't, so what precisely is the issue right now?
 
Hi @Debaser , thanks for the help. Please see below if you get time.

1) One e-mail is saved on a hard drive
2) Macro does browsing and selects e-mail
3) Macro opens e-mail based on path populated in the cell
4) Macro edit this e-mail, add few text line, below these paste an excel range
5) Does some changes to, To, CC, Subject line

Now issue is, macro is not able to add user's default outlook signature below excel range.
Now what am trying, create a new blank e-mail with a different sub
This Sub is creating user's default outlook signature in e-mail body.
Save this signature as picture in worksheet.
Am done till this part.

Pending part is, copying this picture from excel worksheet and paste in email body below the excel range with my original macro.
Have a nice day ahead. :)
 
I agree with you @Debaser , thanks for the help, I tried example from his sites, however somehow I am not able to do it.
Please see below code if you get time.


Code:
Sub OpenEmailWithRange()
    Call DefineWorksheets
    Dim olApp As Object
    Dim olNS As Object
    Dim olMail As Object
    Dim olReply As Object
    Dim strFilePath As String
    Dim strSignature As String
    Dim MyFileName As String
    Dim emailPath As String
    Dim FilePath As String
    Dim olInsp As Object
    
    'Set the file path for the email message
    strFilePath = Sheets("ABC").Range("D37").Value
    
    'Create Outlook application object
    Set olApp = CreateObject("Outlook.Application")
    
    'Create Namespace object
    Set olNS = olApp.GetNamespace("MAPI")
    
    'Open the email message
    Set olMail = olNS.OpenSharedItem(strFilePath)
    
    'Create a reply to all
    Set olReply = olMail.ReplyAll
    
    'Set the subject and To fields of the reply email to match the original email
    olReply.Subject = olMail.Subject
    olReply.To = olMail.To
    
    'Set the recipient, CC, and subject of the email
    olReply.To = Sht_Email.Range("B1").Value2
    olReply.Cc = Sht_Email.Range("B2").Value2
    Sht_Email.Range("B4").Value2 = olReply.Subject
    olReply.Subject = Replace(olReply.Subject, "FW:", "RE:", , , vbTextCompare) & " - " & Sht_TMPLT.Range("D4")
    
    
'''    MyFileName = "Dummy_" & Sht_Map.Range("I2").Value2 & ".xlsb"
'''    FilePath = ThisWorkbook.path & "\" & MyFileName
'''    ActiveWorkbook.SaveAs Filename:=FilePath, FileFormat:=50, CreateBackup:=False
    
    'Add the saved workbook as an attachment to the email
    If olReply.Attachments.Count > 0 Then
        For i = olReply.Attachments.Count To 1 Step -1
            olReply.Attachments.Item(i).Delete
        Next i
    End If
'''    olReply.Attachments.Add FilePath
    
    SigString = Environ("appdata") & "\Microsoft\Signatures\Mysig.htm"
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    
    'Add the email signature to the reply email
    strSignature = olApp.CreateItem(0).HTMLBody
    olReply.HTMLBody = "<span style='font-family: Calibri; font-size: 10pt;'>Dear Valued Client,<br><br>" & _
                       "ABC<br>" & _
                       "ABCD:</span><br><br>" & _
                       Replace(olReply.HTMLBody, "DEFG<br><br><br>", "") & Signature

    
    'Copy the Excel range
    Dim rng As Range
'''    Set rng = Sht_Email.Range("I1:K5")
    
    If Sht_TMPLT.Range("D2") = "Single" Then
        ' Copy a range from the TMPLT sheet and paste it as a bitmap into the email
        lastRow = Sht_Email.Range("$I65000").End(xlUp).Row
        Set rng = Sht_Email.Range("I1:N" & lastRow)
        
        Sht_Email.Columns("I:M").AutoFit
        Sht_Email.Columns("J:J").ColumnWidth = 35
        Sht_Email.Range("I1:N" & lastRow).Rows.AutoFit
        rng.Copy
    End If
    
    'Create a new Word document and paste the range
    Dim wdDoc As Object
    Dim wdRange As Object
    
    Set olInsp = olReply.GetInspector
    
    If Not olInsp Is Nothing Then
        Set wdDoc = olInsp.WordEditor
        Set wdRange = wdDoc.Range
        
        wdRange.Find.Execute "ABCDEF", , , , , , True
        wdRange.Collapse 0
        wdRange.InsertAfter "<br><br>"
        wdRange.Collapse 0
        If Sht_TMPLT.Range("D2") = "Single" Then
            wdRange.PasteExcelTable False, False, False
        End If
'''        wdRange.InsertAfter "<br><br>"
    End If
    
    ' Remove unwanted HTML tags from the email
    wdRange.Find.Execute FindText:="<o:p></o:p>", ReplaceWith:="", Replace:=2
    wdRange.Find.Execute FindText:="<p>&nbsp;</p>", ReplaceWith:="", Replace:=2
    wdRange.Find.Execute FindText:="<p>", ReplaceWith:="", Replace:=2
    wdRange.Find.Execute FindText:="<br><br>", ReplaceWith:="", Replace:=2
    
    ' Replace any remaining "<br>" tags with line breaks
    wdRange.Find.Execute FindText:="<br>", ReplaceWith:=vbCr, Replace:=2

    'Display the reply email
    olReply.Display
    
    'Clean up objects
    Set olReply = Nothing
    Set olMail = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub
 
Above code skips below check.

Code:
If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

If I try to go directly to Signature = GetBoiler(SigString) line then I get bug at

Code:
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.ReadAll
    ts.Close
End Function
 
Okay, how do resolve it, could you please help if you get time. Thanks.
Ron's another code works with new e-mail but not able work with the code you have suggested.
And with Ron's working code, am not able to get the sign which is saved as a picture in the e-mail body.

Ron's code, which created sign in a fresh e-mail.
Code:
Sub Mail_Outlook_With_Signature()
    Dim OutApp As Object          ' Declare object variable for Outlook application
    Dim OutMail As Object         ' Declare object variable for email item
    Dim objInsp As Object         ' Declare object variable for email inspector
    Dim objDoc As Object          ' Declare object variable for email document

    ' Create an instance of the Outlook application and a new email item
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next         ' Turn on error handling

    With OutMail
        .Display                ' Display the email
        .HTMLBody = .HTMLBody   ' Add the signature to the email body
        .Display                ' Display the email again
        .Close 1                ' Close the email without sending it
    End With

    On Error GoTo 0              ' Turn off error handling

    ' Get the email inspector and document objects, then copy the email body to the clipboard
    Set objInsp = OutMail.GetInspector
    Set objDoc = objInsp.WordEditor
    objDoc.Range.Copy
    
    ' Delete all existing pictures from the "Email Guide" worksheet
    Dim pic As Picture
    For Each pic In ThisWorkbook.Worksheets("Email Guide").Pictures
        pic.Delete
    Next pic
    
    ' Paste the email body to the "Email Guide" worksheet with formatting
    ThisWorkbook.Worksheets("Email Guide").Range("Z1").PasteSpecial xlPasteAll
    
    Set OutMail = Nothing         ' Release the email item object from memory
    Set OutApp = Nothing          ' Release the Outlook application object from memory
End Sub
 
Back
Top