How to save outlook messages automatically to a file as they arrive?

Answer 1

The following script demonstrates how to save Outlook messages automatically to a file as new emails arrive to your inbox.

Major parts of the code has been fetched from forums and edited by me.

As end result, you will get all your incoming messages in the following folder structure on your harddrive.

Example:

c:\data\emails

201008

20100801_FirstEmailInAugust.msg

20100801_SomeOtherEmail.msg

20100802_SomeEmailAugust2nd.msg

201009

20100801_FirstEmailInSeptember.msg

Advantages:

- File search can be used to find emails

- No more corrupted PST files (if you have LOTS of emails)

The script has been tested for Microsoft Outlook 2003.

You need to perform following steps:

1. Add the script code

- Open "Tools->Macro->Visual" Basic Editor

- Enter the code as in the end-of the post

2. Add reference to \Windows\System32\Scrrun.dll

- Use "Tools->References..." in Visual Basic Editor

3. Optional: Create a digital certificate

- This is needed if you have medium/high security settings

- In windows, push Start->Programs->Microsoft Office Tools

- Select "Digital Certificate for VBA projects"

- Give some name to your certificate

4. Optional: Sign your code

- This is needed if you have medium/high security settings

- Open "Tools->Digital Signature" in Visual Basic Editor

5. Add outlook rule to process message

- Open "Tools->Rules and Alerts" in Outlook

- Create a new rule (the way you wish)

- As rule action, use "run a script" and select "SaveAsMsg"

The code follows:

-----------------------------------------------------------------------

Sub SaveAsMsg(MyMail As MailItem)

' requires reference to Microsoft Scripting Runtime

' \Windows\System32\Scrrun.dll

' For Coders - see also: http://www.outlookcode.com/article.aspx?id=52

Dim fso As FileSystemObject

Dim strSubject As String

Dim strSaveName As String

Dim blnOverwrite As Boolean

Dim strFolderPath As String

Dim looper As Integer

Dim strID As String

Dim olNS As Outlook.NameSpace

Dim oMail As Outlook.MailItem

' ### For coders: see http://www.outlookcode.com/article.aspx?id=52 for

explanation

strID = MyMail.EntryID

Set olNS = Application.GetNamespace("MAPI")

Set oMail = olNS.GetItemFromID(strID)

' ### USER OPTIONS ###

blnOverwrite = False ' False = don't overwrite, True = do overwrite

strFolderPath = "C:\RAAN\Data\Emails" ' path to target folder

strFolderPath = strFolderPath & Format(Now, " yyyymm") & "" ' Adds year/month

subfolder

If EnsureFolderExistence(strFolderPath) <> "PATH DOES NOT EXIST" Then

strSubject = CleanFileName(oMail.Subject)

strSaveName = Format(Now, " yyyymmdd") & "_" & strSubject & ".msg"

Set fso = CreateObject("Scripting.FileSystemObject")

If blnOverwrite = False Then

looper = 0

Do While fso.FileExists(strFolderPath & strSaveName)

looper = looper + 1

strSaveName = Format(Now, " yyyymmdd") & "_" & strSubject & "_" &

looper & ".msg"

Loop

Else

If fso.FileExists(strFolderPath & strSaveName) Then

fso.DeleteFile strFolderPath & strSaveName

End If

End If

oMail.SaveAs strFolderPath & strSaveName, olMSG

End If

Set oMail = Nothing

Set olNS = Nothing

Set fso = Nothing

End Sub

Function EnsureFolderExistence(strPath) As String

Dim fso As FileSystemObject

On Error Resume Next

Set fso = CreateObject("Scripting.FileSystemObject")

If Not fso.FolderExists(strPath) Then

fso.CreateFolder strPath

If Err <> 0 Then

EnsureFolderExistence = "PATH DOES NOT EXIST"

End If

End If

Set fso = Nothing

End Function

Function CleanFileName(strText As String) As String

Dim strStripChars As String

Dim intLen As Integer

Dim i As Integer

strStripChars = "/\[]:=," & Chr(34)

intLen = Len(strStripChars)

strText = Trim(strText)

For i = 1 To intLen

strText = Replace(strText, Mid(strStripChars, i, 1), "")

Next

CleanFileName = strText

End Function