Outlook 2010 - Append text to body of email - without erasing email

[whig4life]

Hello,

I would like to write a Macro that automatically inserts specific text into the body of an email from a certain address without erasing any of the email text. I am having trouble writing this one, and could use some advice. Please advise, thank you.

[vbfbryce]

Say more. Do you want to add some text to the body, then forward the email, or what exactly?

[whig4life]

Apologies. I just want to add a database tag to the body. We have a program that will sort it once the tag is applied.

[vbfbryce]

Try something like this in a module:

Sub oLook()
    Dim oApp As Application
    Dim oNS As NameSpace
    Dim oFolder As Folder
    Dim myItem As Object
    
    Set oApp = Outlook.Application
    Set oNS = oApp.GetNamespace("MAPI")
    Set oFolder = oNS.GetDefaultFolder(olFolderInbox)
    For Each myItem In oFolder.Items
        If TypeName(myItem) = "MailItem" Then
            On Error Resume Next
            If myItem.Sender = "Sender Name" Then   'change this line ***
                If Err.Number <> 0 Then
                    Err.Clear
                    'write this record to an error log?
                Else
                    myItem.Body = myItem.Body & vbCrLf & vbCrLf & "CODE: XYZ"   'appends code to end of body
                End If
            End If
        End If
    Next
End Sub

[whig4life]

Hello,

Thank you for the reply. I tried this but it didn't quite work. Would there be anything else I would need to do to make it function?

[vbfbryce]

What did happen? Are you running it from Outlook, or elsewhere?

[whig4life]

Running from a module in Outlook. I made the changes I needed to make, but when I tested it with that email address, the text was not in the body of the email. I am sure it is something I am missing, in terms of background knowledge. I am still dusting off the VBA skills. Thank you for your help so far.

[vbfbryce]

can you show your code as is?

[whig4life]

This is what I have:

	

		

			

			
				Sub oLook()
    Dim oApp As Application
    Dim oNS As NameSpace
    Dim oFolder As Folder
    Dim myItem As Object
    
    Set oApp = Outlook.Application
    Set oNS = oApp.GetNamespace("MAPI")
    Set oFolder = oNS.GetDefaultFolder(olFolderInbox)
    For Each myItem In oFolder.Items
        If TypeName(myItem) = "MailItem" Then
            On Error Resume Next
            If myItem.Sender = "pmarrone5488@gmail.com" Then
                If Err.Number <> 0 Then
                    Err.Clear
                Else
                    myItem.Body = myItem.Body & vbCrLf & vbCrLf & "CODE: TESTING"
                End If
            End If
        End If
    Next
End Sub
			
		
	

[TnTinMN]

Just a guess, but won't you need to call MailItem.Save after making any changes?

[whig4life]

can you show your code as is?

Sub oLook()
Dim oApp As Application
Dim oNS As NameSpace
Dim oFolder As Folder
Dim myItem As Object

Set oApp = Outlook.Application
Set oNS = oApp.GetNamespace("MAPI")
Set oFolder = oNS.GetDefaultFolder(olFolderInbox)
For Each myItem In oFolder.Items
If TypeName(myItem) = "MailItem" Then
On Error Resume Next
If myItem.Sender = "pmarrone5488@gmail.com" Then
If Err.Number <> 0 Then
Err.Clear
Else
myItem.Body = myItem.Body & vbCrLf & vbCrLf & "CODE: TESTING"
End If
End If
End If
Next
End Sub

[vbfbryce]

I think Tin is correct in post #10, you need to add a "save" in the loop.

I didn't catch that because i was opening the emails one by one to verify that the text was appended.

Like so:

myItem.Body = myItem.Body & vbCrLf & vbCrLf & "CODE: XYZ"
                    myItem.Save

[whig4life]

I think Tin is correct in post #10, you need to add a "save" in the loop.

I didn't catch that because i was opening the emails one by one to verify that the text was appended.

I see. So, like this: "If TypeName(myItem) = "MailItem.save" Then"

Please let me know if I am correct in my understanding.

[vbfbryce]

I edited in #12 while you were posting.

[whig4life]

I edited in #12 while you were posting.

Thank you very much. Now, once I press run it will be appended, no? Or only on new incoming emails?

[vbfbryce]

When you run, it should append to any that are already in your inbox.

[whig4life]

When you run, it should append to any that are already in your inbox.

It's not working.

[vbfbryce]

put a "stop" in front of this line:

If myItem.Sender = "pmarrone5488@gmail.com" Then

hover over the myitem.sender and see what the value of it is. When I run my code, the sender does not include the "@gmail.com."

[whig4life]

put a "stop" in front of this line:

If myItem.Sender = "pmarrone5488@gmail.com" Then

hover over the myitem.sender and see what the value of it is. When I run my code, the sender does not include the "@gmail.com."

When I hover over it, it only says: vbCrlf=""

Should I remove the @gmail.com?

[whig4life]

[vbfbryce]

add a "watch" for "myitem" and when it stops, see whether myitem has been "set" to a valid object or not.

[whig4life]

Ok I got it working, but it appends the text twice. How do I ensure it only does it once?

[vbfbryce]

You'd need to "mark" the ones that you append to, and skip over them on subsequent passes. You could add something to the subject, or the body, or something else maybe.

[whig4life]

I'm not sure I understand completely.

[vbfbryce]

As an example, the first time you run the code, any emails that were appended to could have the subject changed, something like:

myitem.subject="APP - " & myitem.subject

You could add a check that would then skip any emails whose subject started with "APP - " like so:

if left(myitem.subject,6)<>"APP - " then
   'append
end if

[whig4life]

Ok so, I thought it was working. But instead of appending the text only from those emails from that particular address, it actually appended it to all emails in my inbox. How can I change this?

[vbfbryce]

If your If...Thens line up correctly, it shouldn't be possible, as long as you still have something like this:

If myItem.Sender = "pmarrone5488@gmail.com" Then

If your current code has changed at all, please show the updated version (but not in an image, I can't read it there).

[whig4life]

If your If...Thens line up correctly, it shouldn't be possible, as long as you still have something like this:

If myItem.Sender = "pmarrone5488@gmail.com" Then

If your current code has changed at all, please show the updated version (but not in an image, I can't read it there).

Absolutely:

Sub AppendMail()
Dim oApp As Application
Dim oNS As NameSpace
Dim oFolder As Folder
Dim myItem As Object

Set oApp = Outlook.Application
Set oNS = oApp.GetNamespace("MAPI")
Set oFolder = oNS.GetDefaultFolder(olFolderInbox)
For Each myItem In oFolder.Items
If TypeName(myItem) = "MailItem" Then
If myItem.Sender = "pmarrone5488@gmail.com" Then
On Error Resume Next
If Err.Number <> 0 Then
Err.Clear
Else
myItem.Body = myItem.Body & vbCrLf & vbCrLf & "CODE:TESTING"
myItem.Save
End If
End If
End If
Next
End Sub

[vbfbryce]

It doesn't look like you added the check from #25.

[westconn1]

If myItem.Sender = "pmarrone5488@gmail.com" Then
If Err.Number <> 0 Then
Err.Clear
Else
myItem.Body = myItem.Body & vbCrLf & vbCrLf & "CODE: TESTING"
End If
End If

the logic here is not quite correct, and only seems to get worse with edits

it checks the sender, then if no error edits the body, regardless of who the sender is, SO all emails are edited
i see no specific reason to have inline error checking when returning the sender, so i would remove the on error resume next altogether

You'd need to "mark" the ones that you append to, and skip over them on subsequent passes.

you should be able to check if a constant part of the appended text is already in the emails, rather than change the subject of the item

If myItem.Sender = "pmarrone5488@gmail.com" Then
    if instr(myitem.body, "CODE:") = 0 then myItem.Body = myItem.Body & vbCrLf & vbCrLf & "CODE: TESTING"
End If

i am assuming that some part of the appended string is unlikely to appear in the item body unless it has had the tag appended

[TnTinMN]

This piqued my interest, so I thought that I give it a go. I tried various mechanisms including the one recommended by Bryce (except I used SenderEmailAddress instead of Sender; Sender does not exist in my version) and did not have an issue with double additions. Here is what I finally derived. I'm not making any claims that it is better or worse than what has been presented previously.

Note that this was developed in Outlook 2007, so there may be some changes needed for other versions.

Sub EditReceived(fromEmailAddress As String, tag As String)
   
   Dim app As Application
   Set app = Outlook.Application
   
   Dim ns As Outlook.NameSpace
   Set ns = app.GetNamespace("MAPI")
   
   Dim inboxFolder As Outlook.Folder
   Set inboxFolder = ns.GetDefaultFolder(Outlook.olFolderInbox)
   
   Dim filter As String
   filter = "[SenderEmailAddress] = '" & fromEmailAddress & "'"
   
   Dim filteredItems As Outlook.Items
   Set filteredItems = inboxFolder.Items.Restrict(filter)
   
   Dim item As Outlook.mailitem
   
   For Each item In filteredItems
      item.Body = item.Body & vbCrLf & tag
      item.Save
   Next

End Sub

[westconn1]

and did not have an issue with double additions

what if you ran the code again?

[whig4life]

Hello West,

Thank you for your help. would the below make sense? Please advise, thank you:

Sub AppendMail()
Dim oApp As Application
Dim oNS As NameSpace
Dim oFolder As Folder
Dim myItem As Object

Set oApp = Outlook.Application
Set oNS = oApp.GetNamespace("MAPI")
Set oFolder = oNS.GetDefaultFolder(olFolderInbox)
For Each myItem In oFolder.Items
If TypeName(myItem) = "MailItem" Then
If myItem.Sender = "pmarrone5488@gmail.com" Then
If InStr(myItem.Body, "CODE:") = 0 Then myItem.Body = myItem.Body & vbCrLf & vbCrLf & "CODE: TESTING"
End If
End If
Next
End Sub

[vbfbryce]

Close, but you forgot to save each mail item after adding the CODE to it:

Sub AppendMail()
Dim oApp As Application
Dim oNS As NameSpace
Dim oFolder As Folder
Dim myItem As Object

Set oApp = Outlook.Application
Set oNS = oApp.GetNamespace("MAPI")
Set oFolder = oNS.GetDefaultFolder(olFolderInbox)
For Each myItem In oFolder.Items
    If TypeName(myItem) = "MailItem" Then
        If myItem.Sender = "pmarrone5488@gmail.com" Then
            If InStr(myItem.Body, "CODE:") = 0 Then
                myItem.Body = myItem.Body & vbCrLf & vbCrLf & "CODE: TESTING"
                myItem.Save   'must add this here ***
            End If
        End If
    End If
Next
End Sub

[vbfbryce]

i see no specific reason to have inline error checking when returning the sender, so i would remove the on error resume next altogether

Pete, for some reason I find some "mail items" which generate an error when trying to get the sender. Not sure why!

[whig4life]

Ok, home stretch! It now Says: "Sub or Function not defined", code below for reference.

Sub AppendMail()
Dim oApp As Application
Dim oNS As NameSpace
Dim oFolder As Folder
Dim myItem As Object

Set oApp = Outlook.Application
Set oNS = oApp.GetNamespace("MAPI")
Set oFolder = oNS.GetDefaultFolder(olFolderInbox)
For Each myItem In oFolder.Items
If TypeName(myItem) = "MailItem" Then
If myItem.Sender = "pmarrone5488@gmail.com" Then
If InStr(myItem.Body, "CODE:") = 0 Then myItem.Body = myItem.Body & vbCrLf & vbCrLf & "CODE: TESTING"
myItem.Save
End If
End If
End If
Next
End Sub

[vbfbryce]

what line is giving that error?

[whig4life]

I am not sure how to tell, it only shows that when I run the macro

[vbfbryce]

Copy my code exactly as it appears in #34. It doesn't even run the way you have it in #36, because your IF...THEN's don't match up.

[whig4life]

I did that, it says "Sub or function not defined"

----------------
Sub AppendMail()
Dim oApp As Application
Dim oNS As NameSpace
Dim oFolder As Folder
Dim myItem As Object

Set oApp = Outlook.Application
Set oNS = oApp.GetNamespace("MAPI")
Set oFolder = oNS.GetDefaultFolder(olFolderInbox)
For Each myItem In oFolder.Items
If TypeName(myItem) = "MailItem" Then
If myItem.Sender = "pmarrone5488@gmail.com" Then
If InStr(myItem.Body, "CODE:") = 0 Then
myItem.Body = myItem.Body & vbCrLf & vbCrLf & "CODE: TESTING"
myItem.Save
End If
End If
End If
Next
End Sub