Create new email from the received Email Body with attachment

Status
Not open for further replies.

dreams

New Member
Outlook version
Outlook 2016 64 bit
Email Account
POP3
I am not very familiar with VBA codes. I would like to copy the original received Email Body with attachment and pasted in to a new email.

Currently I am using the below code which I found in a website. But when I use this code, I am getting original sender's signature (instead of changing my signature). Could someone advise how to fix this?

Sub RedirectEmail()
Dim olItem As MailItem
Dim olNewMail As MailItem

Set olItem = Application.ActiveExplorer.Selection.item(1)

If olItem.Class = olMail Then
Set olNewMail = olItem.Forward
With olNewMail
'Remove "FW" prefix in subject
.Subject = olItem.Subject
.HTMLBody = olItem.HTMLBody
.Display
End With
End If
End Sub
 
This line: .HTMLBody = olItem.HTMLBody
is copying the body from the original message, which has the original sender's signature.

This macro shows how to insert a signature using VBA - not sure if the code to remove a signature will work to remove the original signature though.
 
This line: .HTMLBody = olItem.HTMLBody
is copying the body from the original message, which has the original sender's signature.

This macro shows how to insert a signature using VBA - not sure if the code to remove a signature will work to remove the original signature though.
Hi Diane,

Thanks for your response. I tried this. But I am still getting the old signature (original sender's) only.

And my signature is placing above the whole email body (instead of replacing with sender's signature in the bottom of email body). Please see below my edited code and let me know if I am missing anything.


Sub TestEmailRedirect1()
Dim olItem As MailItem
Dim olNewMail As MailItem
Dim Item As Outlook.MailItem
Dim strBuffer As String
enviro = CStr(Environ("appdata"))

Set objFSO = CreateObject("Scripting.FileSystemObject")
' Edit the signature file name on the following line
strSigFilePath = enviro & "\Microsoft\Signatures\"
Debug.Print strSigFilePath
Set objSignatureFile = objFSO.OpenTextFile(strSigFilePath & "Raj.htm")
strBuffer = objSignatureFile.ReadAll
objSignatureFile.Close

Set olItem = Application.ActiveExplorer.Selection.Item(1)

Dim olInspector As Outlook.Inspector
Dim olDocument As Word.Document
Dim olSelection As Word.Selection

If olItem.Class = olMail Then
Set olNewMail = olItem.Forward
With olNewMail
'Remove "FW" prefix in subject
.Subject = olItem.Subject
.Display
End With
End If

Set olInspector = olNewMail.GetInspector
Set olDocument = olInspector.WordEditor
Set olSelection = olDocument.Application.Selection

Set oBookmark = olDocument.Bookmarks("_MailAutoSig")

If Not oBookmark Is Nothing Then
oBookmark.Select
olDocument.Windows(1).Selection.Delete
End If

With olSelection.Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth025pt
.Color = wdColorGray10
End With

olNewMail.HTMLBody = "<p>&nbsp;</p>" & strBuffer & olItem.HTMLBody
olSelection.MoveStart


End Sub
 
Does the incoming mail have the autosig bookmark? You will need to look at the message source and see what is common in all of the messages you need to use the macro on.

This part of the code is looking for the bookmark:
Set oBookmark = olDocument.Bookmarks("_MailAutoSig")

If Not oBookmark Is Nothing Then
oBookmark.Select
olDocument.Windows(1).Selection.Delete
End If

 
Does the incoming mail have the autosig bookmark? You will need to look at the message source and see what is common in all of the messages you need to use the macro on.

This part of the code is looking for the bookmark:
Set oBookmark = olDocument.Bookmarks("_MailAutoSig")

If Not oBookmark Is Nothing Then
oBookmark.Select
olDocument.Windows(1).Selection.Delete
End If

Hi Diane,

Understood. But I am not very familiar with VBA. I couldn't able to fix this. I have attached source file (txt) of the original email. Can you check and advise what I need to do.
 

Attachments

  • email.txt
    13.1 KB · Views: 182
Assuming this is the signature

2021-05-27_14-51-23-0000.png

As long as the sender didn't add a table to the message, you could look for the table or table class and delete everything to the end.
Code:
table class=MsoNormalTable border=0 cellspacing=0 cellpadding=0 width=357
 style='width:267.4pt;margin-left:.1pt'


in a quick test - setting a bookmark for the first table worked - but the last line of code deleted everything.
Set olSelection = olDocument.Application.Selection

olSelection.Tables(1).Range.Bookmarks.Add "tb1"

Set oBookmark = olDocument.Bookmarks("tb1")


This code deleted everything - could be just my setup (its a test mailbox) -
olNewMail.HTMLBody = "<p>&nbsp;</p>" & strBuffer & olItem.HTMLBody
olSelection.MoveStart
 
The code below gets me this - but as soon as I try to add the signature to the body, this part is deleted. :( If I move the signature to the bottom, it works. I'm guessing its HTML tags (/body amd </html) in the signature string closing out.
2021-05-27_15-51-00-0000.png



Code:
Sub TestEmailRedirect1()
Dim olItem As mailItem
Dim olNewMail As mailItem
Dim Item As Outlook.mailItem
Dim strBuffer As String
enviro = CStr(Environ("appdata"))

Set objFSO = CreateObject("Scripting.FileSystemObject")
' Edit the signature file name on the following line
strSigFilePath = enviro & "\Microsoft\Signatures\"
Set objSignatureFile = objFSO.OpenTextFile(strSigFilePath & "signaturename.htm")
strBuffer = objSignatureFile.ReadAll
objSignatureFile.Close

Set olItem = Application.ActiveExplorer.Selection.Item(1)
Dim olInspector As Outlook.Inspector
Dim olDocument As Word.Document
Dim olSelection As Word.Selection

If olItem.Class = olMail Then
Set olNewMail = olItem.Forward
With olNewMail
'Remove "FW" prefix in subject
olNewMail.HTMLBody = olItem.HTMLBody
.Subject = olItem.Subject
.Display
End With
End If

Set olInspector = olNewMail.GetInspector
Set olDocument = olInspector.WordEditor
Set objWord = olDocument.Application
Set olSelection = objWord.Selection
       

' need to select the body for outlook to see the tables
olSelection.WholeStory

Debug.Print olSelection.Range.Tables.Count

olSelection.Tables(1).Range.Bookmarks.Add "tb1"

Set oBookmark = olDocument.Bookmarks("tb1")

If Not oBookmark Is Nothing Then
oBookmark.Select
olDocument.Windows(1).Selection.Delete
End If

With olSelection.Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth025pt
.Color = wdColorGray10
End With

' this is deleting the body
'olNewMail.HTMLBody = "<p>&nbsp;</p>" & vbCrLf & strBuffer & vbCrLf & olNewMail.HTMLBody
olSelection.MoveStart


End Sub
 
Last edited:
The code below gets me this - but as soon as I try to add the signature to the body, this part is deleted. :( If I move the signature to the bottom, it works. I'm guessing its HTML tags (/body amd </html) in the signature string closing out.
View attachment 3330


Code:
Sub TestEmailRedirect1()
Dim olItem As mailItem
Dim olNewMail As mailItem
Dim Item As Outlook.mailItem
Dim strBuffer As String
enviro = CStr(Environ("appdata"))

Set objFSO = CreateObject("Scripting.FileSystemObject")
' Edit the signature file name on the following line
strSigFilePath = enviro & "\Microsoft\Signatures\"
Set objSignatureFile = objFSO.OpenTextFile(strSigFilePath & "signaturename.htm")
strBuffer = objSignatureFile.ReadAll
objSignatureFile.Close

Set olItem = Application.ActiveExplorer.Selection.Item(1)
Dim olInspector As Outlook.Inspector
Dim olDocument As Word.Document
Dim olSelection As Word.Selection

If olItem.Class = olMail Then
Set olNewMail = olItem.Forward
With olNewMail
'Remove "FW" prefix in subject
olNewMail.HTMLBody = olItem.HTMLBody
.Subject = olItem.Subject
.Display
End With
End If

Set olInspector = olNewMail.GetInspector
Set olDocument = olInspector.WordEditor
Set objWord = olDocument.Application
Set olSelection = objWord.Selection
      

' need to select the body for outlook to see the tables
olSelection.WholeStory

Debug.Print olSelection.Range.Tables.Count

olSelection.Tables(1).Range.Bookmarks.Add "tb1"

Set oBookmark = olDocument.Bookmarks("tb1")

If Not oBookmark Is Nothing Then
oBookmark.Select
olDocument.Windows(1).Selection.Delete
End If

With olSelection.Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth025pt
.Color = wdColorGray10
End With

' this is deleting the body
'olNewMail.HTMLBody = "<p>&nbsp;</p>" & vbCrLf & strBuffer & vbCrLf & olNewMail.HTMLBody
olSelection.MoveStart


End Sub
Understood, Thanks for your help. I will try to work with this. Thank you so much.

One more question: It seems that some other emails doesn't have table or table class available (please see below pasted source code). Can you tell me how to change this when table class is not available?

Otherwise the common word for all emails will be "With Best Regards (or) Thank you (or) test@domain.com" (will be placed above signature). Is it possible to remove all texts below these words (including these words need to remove) ?

Thank you in advance.

<p ><b><font size=1 color="#1f497d" face="Times New Roman"><span
style='font-size:8.0pt;color:#1F497D;font-weight:bold'>With Best Regards</span></font></b><b><font
size=1 color="#548dd4"><span style='font-size:8.0pt;color:#548DD4;font-weight:
bold'>,<o:p></o:p></span></font></b></p>
<p style='line-height:115%'><b><font size=1 color="#646464"
face="Times New Roman"><span style='font-size:8.0pt;line-height:115%;
color:#646464;font-weight:bold'>test | Office | Team </span></font></b><font
size=1><span style='font-size:8.0pt;line-height:115%'><o:p></o:p></span></font></p>
<p ><b><font size=1 color=olive face=Arial><span
style='font-size:8.0pt;font-family:Arial;color:eek:live;font-weight:bold'>test</span></font></b><b><font
size=1 face=Arial><span style='font-size:8.0pt;font-family:Arial;font-weight:
bold'> <font color="#336699"><span style='color:#336699'>test and test Pvt
Ltd</span></font></span></font></b><b><font size=1 color="#336699"><span
style='font-size:8.0pt;color:#336699;font-weight:bold'><o:p></o:p></span></font></b></p>
 
Otherwise the common word for all emails will be "With Best Regards (or) Thank you (or) test@domain.com" (will be placed above signature). Is it possible to remove all texts below these words (including these words need to remove) ?
Yes, its possible to find those words and delete - I don't think I have code to do it but will look.

and if you want your signature at the end, use the following-that worked when I was testing (and did not remove the body).
olNewMail.HTMLBody = olItem.HTMLBody & strBuffer
 
Didn't have a macro that did exactly this but had one that was close I could cannibalize from.

Code:
Sub TestEmailRedirect1()
Dim olItem As mailItem
Dim olNewMail As mailItem
Dim Item As Outlook.mailItem
Dim strBuffer As String
enviro = CStr(Environ("appdata"))

Set objFSO = CreateObject("Scripting.FileSystemObject")
' Edit the signature file name on the following line
strSigFilePath = enviro & "\Microsoft\Signatures\"
Set objSignatureFile = objFSO.OpenTextFile(strSigFilePath & "signaturename.htm")
strBuffer = objSignatureFile.ReadAll
objSignatureFile.Close

Set olItem = Application.ActiveExplorer.Selection.Item(1)
Dim olInspector As Outlook.Inspector
Dim olDocument As Word.Document
Dim olSelection As Word.Selection

If olItem.Class = olMail Then
Set olNewMail = olItem.Forward
With olNewMail
'Remove "FW" prefix in subject
olNewMail.HTMLBody = olItem.HTMLBody
.Subject = olItem.Subject
.Display
End With
End If

Set olInspector = olNewMail.GetInspector
Set olDocument = olInspector.WordEditor
Set objWord = olDocument.Application
Set olSelection = objWord.Selection
        
olSelection.Bookmarks("\StartOfDoc").Select

  olSelection.Find.ClearFormatting

For lphrase = 1 To 2

Select Case lphrase
Case 1
  strFind = "Thank you"
Case 2
  strFind = "With Best Regards,"
End Select

  With olSelection.Find
    .Text = strFind
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
  End With
  olSelection.Find.Execute
  
If Not olSelection.Find.Found Then GoTo nextphrase
olSelection.EndOf Unit:=wdStory, Extend:=wdExtend
olSelection.Delete Unit:=wdCharacter, Count:=1

nextphrase:
Next

With olSelection.Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth025pt
.Color = wdColorGray10
End With

olNewMail.HTMLBody = olNewMail.HTMLBody & strBuffer

olSelection.MoveStart

End Sub
 
Didn't have a macro that did exactly this but had one that was close I could cannibalize from.

Code:
Sub TestEmailRedirect1()
Dim olItem As mailItem
Dim olNewMail As mailItem
Dim Item As Outlook.mailItem
Dim strBuffer As String
enviro = CStr(Environ("appdata"))

Set objFSO = CreateObject("Scripting.FileSystemObject")
' Edit the signature file name on the following line
strSigFilePath = enviro & "\Microsoft\Signatures\"
Set objSignatureFile = objFSO.OpenTextFile(strSigFilePath & "signaturename.htm")
strBuffer = objSignatureFile.ReadAll
objSignatureFile.Close

Set olItem = Application.ActiveExplorer.Selection.Item(1)
Dim olInspector As Outlook.Inspector
Dim olDocument As Word.Document
Dim olSelection As Word.Selection

If olItem.Class = olMail Then
Set olNewMail = olItem.Forward
With olNewMail
'Remove "FW" prefix in subject
olNewMail.HTMLBody = olItem.HTMLBody
.Subject = olItem.Subject
.Display
End With
End If

Set olInspector = olNewMail.GetInspector
Set olDocument = olInspector.WordEditor
Set objWord = olDocument.Application
Set olSelection = objWord.Selection
       
olSelection.Bookmarks("\StartOfDoc").Select

  olSelection.Find.ClearFormatting

For lphrase = 1 To 2

Select Case lphrase
Case 1
  strFind = "Thank you"
Case 2
  strFind = "With Best Regards,"
End Select

  With olSelection.Find
    .Text = strFind
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
  End With
  olSelection.Find.Execute
 
If Not olSelection.Find.Found Then GoTo nextphrase
olSelection.EndOf Unit:=wdStory, Extend:=wdExtend
olSelection.Delete Unit:=wdCharacter, Count:=1

nextphrase:
Next

With olSelection.Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth025pt
.Color = wdColorGray10
End With

olNewMail.HTMLBody = olNewMail.HTMLBody & strBuffer

olSelection.MoveStart

End Sub
Hi Diane,

It works very fine. Thank you so much for your help.
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
S Create Outlook Task from Template and append Body with Email Body Outlook VBA and Custom Forms 4
Wotme create email only data file Using Outlook 1
L Capture email addresses and create a comma separated list Outlook VBA and Custom Forms 5
D Create advanced search (email) via VBA with LONG QUERY (>1024 char) Outlook VBA and Custom Forms 2
P Can I create a Rule that sends me an email when I get a Task? Using Outlook 2
M How create a Rule to filter sender's email with more that one @ sign Using Outlook 1
D Can Exchange Admin Center create a pst for users email/contacts/calendar? Exchange Server Administration 0
O Multiple email accounts - hesitate to create a new profile Using Outlook 3
W Create Search Folder excluding Specific Email Addresses Using Outlook 5
JackBlack What tools do you use to create the signature for email? Using Outlook 3
Rupert Dragwater How to create a new email with @outlook.com Using Outlook.com accounts in Outlook 32
F Should a new email account also create new contacts Using Outlook 2
R Outlook add-in to create new contact from an email. Using Outlook 0
G How do I create a custom pick list in VB for an outlook automated email? Outlook VBA and Custom Forms 1
Stilgar Relsik Create a rule to copy text from an email and paste it in the subject line. Using Outlook 1
B Macro To Create Rule To Export From Certain Folder Email Information in one workbook multiple sheets Outlook VBA and Custom Forms 0
G Create an Appointment at the Contact's Address From Email Outlook VBA and Custom Forms 0
Diane Poremsky Create a Task from an Email using a Rule Using Outlook 0
Diane Poremsky Create Appointment From Email Automatically Using Outlook 0
B VBA Code to create appointment from email Outlook VBA and Custom Forms 1
Diane Poremsky Create an Outlook appointment from an email message Using Outlook 4
A Create Macro for hyperlink(email) in message body Outlook VBA and Custom Forms 9
Diane Poremsky Create Tasks from Email and move to different Task folders Using Outlook 0
S Create task with email URL instead of attachment Outlook VBA and Custom Forms 4
rc4524 Create auto follow-up reminder email for already sent messages Outlook VBA and Custom Forms 1
anoble1 How to create an email with a link to add a calendar appointment Using Outlook 1
A Create Task from Email and put body & email as attachment into task notes Outlook VBA and Custom Forms 17
D Create Exchange Rule for everyone that highlights an email based on content of subject Exchange Server Administration 1
H Create a Task by Draft-EMail > Task+Reminder not Working Outlook VBA and Custom Forms 1
R Auto-create receipt from email and forward to payer Using Outlook 3
M How to create a document or email template for Opportunities BCM (Business Contact Manager) 0
G Create rule based on image in email body Using Outlook 1
anoble1 Can you create a rule once an email moves to the Vault Inbox to another place? Using Outlook 0
C Visual Basic auto create task from email including attachments Using Outlook 9
2 Create an email brochure - oft file? Using Outlook 3
C Create a rule to only check new content in email - disregard original content Using Outlook 3
K Outlook Cached Mode - can't create rules to move email to another mailbox Using Outlook 2
O Can't create new email or access email acounts Outlook 2003 Using Outlook 1
M Create Rule to BCC email? Using Outlook 2
O Outlook 2010 - How to create custom Group By Arrangements for email Using Outlook 3
K Create individualized employee email messages Outlook VBA and Custom Forms 1
P How do I create a macro to add contacts from email messages? Outlook VBA and Custom Forms 1
S How to Create Buttons in email body / toolbar Outlook VBA and Custom Forms 3
S HELP: Create Buttons in Outlook Email body or Tool bar Outlook VBA and Custom Forms 1
T How to create an email template that generates a text email Outlook VBA and Custom Forms 1
S Create Auto eMail with Web table Content Outlook VBA and Custom Forms 1
B Create email from Access on Outlook and make sure that email has b Outlook VBA and Custom Forms 1
M Create email from Access on Outlook and make sure that email has beensent using WithEvents method Outlook VBA and Custom Forms 3
B Modify VBA to create a RULE to block multiple messages Outlook VBA and Custom Forms 0
J Want to create a button on the nav bar (module add-in) to run code Outlook VBA and Custom Forms 2

Similar threads

Back
Top