Saving All Messages to the Hard Drive Using VBA

Chia sẻ bởi:hands

★★★★★

‹ Send an Email When a Reminder Fires How to Open Outlook Templates and Files... ›

Quảng cáo

Use this code to save messages with the date in the filename, retaining the Outlook file structure.

To save selected messages as PDF files, see [URL='www.slipstick.com/developer/code-samples/save-outlook-email-pdf/']Save Outlook email as a PDF

This code sample will save all messages in a specific Outlook folder (and any subfolders of the selected folder) in a folder you select on the hard drive. The messages will be in a subfolder of the selected folder, where the subfolder is named for the Outlook folder you selected.

Note: if you select a subfolder of a top-level folder, for example, a subfolder of the Inbox, folder named Inbox needs to exist in path on the hard drive.

The filename format is yyyymmdd_hhmm_subject.msg, as in:

20100422_0319_Inquiry.msg

The filename is set using this code:

StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"

Filenames are limited to 256 characters in length, with the subject trimmed if its too long.

Note that it can take some time to run if the folder contains a lot of messages. Allow about 2 seconds per message, or about 15 minutes for 400 messages.

VBA Code

Click in the code area, press Ctrl+A to select all, Ctrl+C to copy then paste into Outlook's VBA editor. Instructions on using the editor are at [URL='www.slipstick.com/developer/how-to-use-outlooks-vba-editor/']How to use Outlook's VBA Editor

Option Explicit
       Dim StrSavePath     As String

Sub SaveAllEmails_ProcessAllSubFolders()

Dim i               As Long
    Dim j               As Long
    Dim n               As Long
    Dim StrSubject      As String
    Dim StrName         As String
    Dim StrFile         As String
    Dim StrReceived     As String
    Dim StrFolder       As String
    Dim StrSaveFolder   As String
    Dim StrFolderPath   As String
    Dim iNameSpace      As NameSpace
    Dim myOlApp         As Outlook.Application
    Dim SubFolder       As MAPIFolder
    Dim mItem           As MailItem
    Dim FSO             As Object
    Dim ChosenFolder    As Object
    Dim Folders         As New Collection
    Dim EntryID         As New Collection
    Dim StoreID         As New Collection

Set FSO = CreateObject("Scripting.FileSystemObject")
    Set myOlApp = Outlook.Application
    Set iNameSpace = myOlApp.GetNamespace("MAPI")
    Set ChosenFolder = iNameSpace.PickFolder
    If ChosenFolder Is Nothing Then
GoTo ExitSub:
    End If

BrowseForFolder StrSavePath

Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)

For i = 1 To Folders.Count
        StrFolder = StripIllegalChar(Folders(i))
        n = InStr(3, StrFolder, "") + 1
        StrFolder = Mid(StrFolder, n, 256)
        StrFolderPath = StrSavePath & "" & StrFolder & ""
        StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & ""
        If Not FSO.FolderExists(StrFolderPath) Then
            FSO.CreateFolder (StrFolderPath)
        End If

Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
        On Error Resume Next
        For j = 1 To SubFolder.Items.Count
            Set mItem = SubFolder.Items(j)
            StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm")
            StrSubject = mItem.Subject
            StrName = StripIllegalChar(StrSubject)
            StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
            StrFile = Left(StrFile, 256)
            mItem.SaveAs StrFile, 3
        Next j
        On Error GoTo 0
    Next i

ExitSub:

End Sub

Function StripIllegalChar(StrInput)
    Dim RegX            As Object

Set RegX = CreateObject("vbscript.regexp")

RegX.Pattern = "[" & Chr(34) & "!@#$%^&*()=+|[]{}`';:<>?/,]"
    RegX.IgnoreCase = True
    RegX.Global = True

StripIllegalChar = RegX.Replace(StrInput, "")

ExitFunction:
    Set RegX = Nothing

End Function

Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)
    Dim SubFolder       As MAPIFolder

Folders.Add Fld.FolderPath
    EntryID.Add Fld.EntryID
    StoreID.Add Fld.StoreID
    For Each SubFolder In Fld.Folders
        GetFolder Folders, EntryID, StoreID, SubFolder
    Next SubFolder

ExitSub:
    Set SubFolder = Nothing

End Sub

Function BrowseForFolder(StrSavePath As String, Optional OpenAt As String) As String
    Dim objShell As Object
    Dim objFolder '  As Folder

Dim enviro
enviro = CStr(Environ("USERPROFILE"))
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", 0, enviro & "Documents")
StrSavePath = objFolder.self.Path

On Error Resume Next
    On Error GoTo 0

ExitFunction:
    Set objShell = Nothing

End Function

How to use this macro

IXxQ9dwyl_w

First: You need to have macro security set to low during testing. The macros will not work otherwise.

To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it's at Tools, Macro Security.

After you test the macro and see that it works, you can either leave macro security set to low or [URL='www.slipstick.com/developer/how-to-use-outlooks-vba-editor/']sign the macro.

Open the VBA Editor by pressing Alt+F11 on your keyboard.

Right click on Project1 and choose Insert > Module
Copy and paste the macro into the new module.

More information as well as screenshots are at [URL='www.slipstick.com/developer/how-to-use-outlooks-vba-editor/']How to use the VBA Editor

More Information

[URL='www.slipstick.com/outlook/email/how-to-save-email-in-windows-file-system/']How to Save Email in Windows File System
[URL='www.slipstick.com/developer/code-samples/move-messages-file-system-outlook/']Import Messages from File System into Outlook Folders
[URL='www.slipstick.com/exchange/web-access/owa-save-messages-documents/']OWA: Save Messages to My Documents
[URL='www.slipstick.com/problems/how-to-save-a-message-as-html-and-delete-the-annoying-folder/']Save a Message as HTML and Delete the (Annoying) Folder
[URL='www.slipstick.com/developer/code-samples/save-email-message-text-file/']Save email message as text file
[URL='www.slipstick.com/developer/code-samples/save-outlook-email-pdf/']Save Outlook Email as a PDF
[URL='www.slipstick.com/developer/code-samples/save-selected-message-file/']Save Selected Email Message as .msg File
[URL='www.slipstick.com/developer/saving-messages-to-the-hard-drive-using-vba/']Saving All Messages to the Hard Drive Using VBA

www.slipstick.com/developer/saving-messages-to-the-hard-drive-using-vba/