Macro that copies and pastes text from an Outlook e-mail into a Word document upon receipt.

[bdhopp]

Hello:

I want to create a custom action in Outlook that will--upon receipt of an e-mail from a specific sender--trigger a macro to copy the text in the Outlook e-mail and paste it into a Word or Excel document. Can anyone help me get started with this? Thank you!

 

[Ruddles]

This was knocked up in a bit of a hurry but it seems to work.

First of all, in VBA add a reference to the Microsoft Word Object Library (Tools > References).

Paste the code in your ThisOutlookSession's code window. Change the bit in red to point to folder where you want the Word documents saved. The filename is made up from the word "Mail" plus the date and time the macro ran and a one-up serial number per email, like: "Mail_21Feb11_230113_0001" (.doc or.docx). This is to ensure we get a unique filename for every email.

The bit in pink is where the contents of the email get copied to the Word document. If you want to copy more stuff, just add more wordRange.InsertAfter commands.

The comment in green indicates where you can do some filtering on the incoming mail: if you start typing If objMailItem. you will get a drop-down list of the various properties you can test. Leave that for later - just get the code working first before you start modifying it.

Option Explicit
 
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
 
  Dim objMailItem As MailItem
  Dim arrMailItems() As String
  Dim iCount As Integer
  
  Const SavePath As String = "[COLOR=red][B]C:\Temp\[/B][/COLOR]"
  Dim ThisDocument As String
  
  Dim wordApp As Word.Application
  Dim wordDoc As Word.Document
  Dim wordRange As Word.Range
  
  ThisDocument = [COLOR=blue][B]"Mail_" & Format(Now(), "ddmmmyy_hhnnss")
[/B][/COLOR]  
  arrMailItems = Split(EntryIDCollection, ",")
    
  For iCount = 0 To UBound(arrMailItems)
    Set objMailItem = Application.Session.GetItemFromID(arrMailItems(iCount))
[COLOR=green]    ' here you can [COLOR=green]check objMailItem.SenderName or objMailItem.Subject[/COLOR] here (for example)[/COLOR]
    Set wordApp = CreateObject("Word.Application")
    With wordApp
      .WindowState = Word.WdWindowState.wdWindowStateMaximize
      .Documents.Add ("normal.dotm")
      Set wordDoc = .ActiveDocument
      Set wordRange = wordDoc.Range
[COLOR=#ff00ff][B]      wordRange.InsertAfter objMailItem.Body
[/B][/COLOR]      .ActiveDocument.SaveAs SavePath & ThisDocument & "_" & Right("000" & CStr(iCount + 1), 4)
      .ActiveDocument.Close
      .Application.Quit
      Set wordDoc = Nothing
      Set wordApp = Nothing
    End With
  Next iCount
 
End Sub

Let me know how it goes?

 

[bdhopp]

I will try it, as soon as I can. Thank you!

 

[ttratl]

Hey Ruddles,

This code is in the area of something I'm looking at...

Your code works for me (Office 2007), although the file number doesn't increment.

I am unable to work out how to do the filtering for one specific sender. I see you have put instructions, but I can't work out what to comment out and what to insert.
Say I wanted this code to run only against emails from jbloggs@somewhere.com - how would I change your code?

Thanks

 

[Ruddles]

Your code works for me (Office 2007), although the file number doesn't increment.

The file number is only incremented within each incoming mail scan. If you have two mails arriving at the same time, the file number increments - it has to otherwise the file names would be the same. If two mails come in at different times, the date/time in the file name is different but the file number would be 0001 for both of them.

Is that what's happening with you?

Do you need the file numbers to increment regardless of the date/time the mail arrived? If so, tell me how many digits you need and I'll let you have a modified version of the code.

 

[Ruddles]

Say I wanted this code to run only against emails from jbloggs@somewhere.com - how would I change your code?

Immediately after the Set objMailItem command, where the comment is, insert this line:-

If objMailItem.SenderEmailAddress="[EMAIL="jbloggs@somewhere.com"]jbloggs@somewhere.com[/EMAIL]" Then

The matching End If will have to go here:-

[FONT=Courier New]      End With[/FONT]
[FONT=Courier New]    [COLOR=red][B]End If
[/B][/COLOR]  Next iCount
[/FONT]

Note: when you start typing If objMailItem., pause for a moment after typing the dot as you should get a pop-up list containing all the properties of the mail that you can use. Scroll up and down this list as you might find other useful things in there.

 

[Ruddles]

Do you need the file numbers to increment regardless of the date/time the mail arrived? If so, tell me how many digits you need and I'll let you have a modified version of the code.

I can't see a simple way of rolling over the file numbers from one day to the next but if you want a single sequence of numbers per Outlook session, do this:-

1) Create a new standard code module containing:-

Public FILE_SEQUENCE As Long

2) Replace the SaveAs statement with the following:-

      FILE_SEQUENCE = FILE_SEQUENCE + 1
      .ActiveDocument.SaveAs SavePath & ThisDocument & "_" & Right("000" & CStr(FILE_SEQUENCE + 1), 4)

 

[ttratl]

Hi Ruddles,

I may have mislead you - the file names are not an issue for me, I just noticed they weren't incrementing, so I mentioned it.
However, I did send two emails one after the other as fast as I could, and the file names ended up as
Mail_24Feb11_090100_0001.docx
Mail_24Feb11_090103_0001.docx
Which is how you intended I think. So that's fine.

I have tried to filter by SenderEmailAddress and not managed to get this to work. I tried the usual SMTP addressing and when that didn't work, I tried the name that appears in the From box (e.g. Smith, John T). Neither worked. Also tried SenderName with both addressing options with same result.

I had success with Subject filtering - that worked fine.

Also, your code seems to bug when a read receipt comes in at this line

Set objMailItem = Application.Session.GetItemFromID(arrMailItems(iCount))

Anyway, I've decided to go in a different direction, but hope this may help out bdhopp, or others...

Thanks Ruddles.

 

[Ruddles]

I have tried to filter by SenderEmailAddress and not managed to get this to work. I tried the usual SMTP addressing and when that didn't work, I tried the name that appears in the From box (e.g. Smith, John T). Neither worked. Also tried SenderName with both addressing options with same result.

In case anyone is following this thread or comes across it at some point in the future, if you experience any difficulties ascertaining exactly what the incoming data looks like - let's say the sender's email address - you can insert something like Debug.Print objMailItem.SenderEmailAddress or MsgBox objMailItem.SenderEmailAddress after the Set objMailItem statement and this will show you exactly what the field contains.

Also, your code seems to bug when a read receipt comes in at this line

Set objMailItem = Application.Session.GetItemFromID(arrMailItems(iCount))

Ah, I thought it was going too smoothly! I did knock it up in a bit of a rush as I explained - I think all I need to do is find out what type of item a read receipt is and just skip over any that I encounter. It's probably a trivial change: I shall look at it tonight when I get home and post a correction.

 

[Ruddles]

your code seems to bug when a read receipt comes in at this line

Set objMailItem = Application.Session.GetItemFromID(arrMailItems(iCount))

I'd rather test the item type directly but this will do the job until I can work out how to do that:-

Option Explicit
 
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
 
  Dim objMailItem As MailItem
  Dim arrMailItems() As String
  Dim iCount As Integer
  
  Const SavePath As String = "C:\Temp\"
  Dim ThisRun As String
  
  Dim wordApp As Word.Application
  Dim wordDoc As Word.Document
  Dim wordRange As Word.Range
  
  ThisRun = Format(Now(), "ddmmmyy_hhnnss")
  
  arrMailItems = Split(EntryIDCollection, ",")
    
  For iCount = 0 To UBound(arrMailItems)
[COLOR=red][B]    On Error Resume Next
    Set objMailItem = Application.Session.GetItemFromID(arrMailItems(iCount))
    On Error GoTo 0
    If Not objMailItem Is Nothing Then
[/B][/COLOR]      ' here you can check objMailItem.SenderName or objMailItem.Subject here (for example)
      Set wordApp = CreateObject("Word.Application")
      With wordApp
        .WindowState = Word.WdWindowState.wdWindowStateMaximize
        .Documents.Add ("normal.dotm")
        Set wordDoc = .ActiveDocument
        Set wordRange = wordDoc.Range
        wordRange.InsertAfter objMailItem.Body
        .ActiveDocument.SaveAs SavePath & "Mail_" & ThisRun & "_" & Right("000" & CStr(iCount + 1), 4)
        .ActiveDocument.Close
        .Application.Quit
        Set wordDoc = Nothing
        Set wordApp = Nothing
      End With
[B][COLOR=red]    End If
[/COLOR][/B]  Next iCount
 
End Sub