Saving e-mails to another format

[kjon99fm]

Hello,



My father has a real old version of MS office Outlook (probably around the turn of the century). Anyways, he wants to get out of Outlook completely. He has hundreds to thousands of old e-mails in folders in his inbox he'd like to keep - if possible - but to save them onto his PC (running Windows 7-64bit) so they do not require Outlook program to open them if he ever needed to. Question: can Outlook e-mails be saved into another format (like .txt or even .docx) or do they need to be saved as an Outlook e-mail file and then converted using another third-party program? Other possible solutions? Links to step-by-step instructions are wonderful. Thanks!

[gmayor]

Obviously I cannot check in your father's unknown Outlook version, but he may be able to use the following Outlook Macros (which I have posted here before) to save the messages in his inbox and its sub folders as Word compatible RTF format.

This will take a while to run without much indication of progress. However because of the forum format I have commented out the references to the progress indicator that would correct this issue.

He will also need sufficient disc space to store hundreds of messages in RTF format.

The code takes no account of attachments that may be attached to the messages.

If you want the progress indicator, you can download it from http://www.gmayor.com/Zips/ProgressBar.zip and resurrect the userform commands

Option Explicit

Sub SaveMessages()
'Graham Mayor - http://www.gmayor.com
Dim cFolders As Collection
Dim olFolder As Outlook.Folder
Dim subFolder As Outlook.Folder
Dim olNS As Outlook.NameSpace
Dim strPath As String
Dim sSubPath As String
Dim sStore As String

    strPath = InputBox("Enter the path to save the messages." & vbCr & _
                       "The path will be created if it doesn't exist.", _
                       "Save Message", "C:\Outlook Message Backup\")

    Do Until Right(strPath, 1) = Chr(92)
        strPath = strPath & Chr(92)
    Loop

    Set cFolders = New Collection
    Set olNS = GetNamespace("MAPI")
    cFolders.Add olNS.GetDefaultFolder(olFolderInbox)
    Do While cFolders.Count > 0
        Set olFolder = cFolders(1)
        cFolders.Remove 1
        sStore = olFolder.Store
        sSubPath = Replace(olFolder.FolderPath, "\\" & sStore & "\", strPath)
        CreateFolders sSubPath
        ProcessFolder olFolder, sSubPath
        If olFolder.folders.Count > 0 Then
            For Each subFolder In olFolder.folders
                cFolders.Add subFolder
            Next subFolder
        End If
    Loop
lbl_Exit:
    Set olFolder = Nothing
    Set subFolder = Nothing
    Exit Sub
End Sub

Private Sub ProcessFolder(olMailFolder As Outlook.Folder, sPath As String)
'Graham Mayor - http://www.gmayor.com
Dim olItems As Outlook.Items
Dim olMailItem As Outlook.MailItem
Dim i As Long
    'Dim oFrm As New frmProgress
Dim PortionDone As Double

    On Error GoTo err_Handler

    Set olItems = olMailFolder.Items
    'oFrm.Show vbModeless
    i = 0
    For Each olMailItem In olItems
        i = i + 1
        'PortionDone = i / olItems.Count
        'oFrm.Caption = olMailFolder.Name & " - Processing " & i & " of " & olItems.Count
        'oFrm.lblProgress.Width = oFrm.fmeProgress.Width * PortionDone
        SaveMessage olMailItem, sPath
        DoEvents
    Next olMailItem
    'Unload oFrm
lbl_Exit:
    'Set oFrm = Nothing
    Set olItems = Nothing
    Set olMailItem = Nothing
    Exit Sub
err_Handler:
    MsgBox Err.Number & vbCr & Err.Description
    Err.Clear
    GoTo lbl_Exit
End Sub

Private Sub SaveMessage(olItem As MailItem, sPath As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim fname As String

    fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
            Format(olItem.ReceivedTime, "HH.MM") & " - " & olItem.SenderName & " - " & olItem.Subject
    fname = Replace(fname, Chr(58) & Chr(41), "")
    fname = Replace(fname, Chr(58) & Chr(40), "")
    fname = Replace(fname, Chr(34), "-")
    fname = Replace(fname, Chr(42), "-")
    fname = Replace(fname, Chr(47), "-")
    fname = Replace(fname, Chr(58), "-")
    fname = Replace(fname, Chr(60), "-")
    fname = Replace(fname, Chr(62), "-")
    fname = Replace(fname, Chr(63), "-")
    fname = Replace(fname, Chr(124), "-")
    SaveUnique olItem, sPath, fname
lbl_Exit:
    Exit Sub
End Sub

Private Function SaveUnique(oItem As Object, _
                            strPath As String, _
                            strFileName As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim lngF As Long
Dim lngName As Long
Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")

    lngF = 1
    lngName = Len(strFileName)
    Do While oFSO.FileExists(strPath & strFileName & ".rtf") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFileName & ".rtf", olRTF
lbl_Exit:
    Set oFSO = Nothing
    Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Office macro by Graham Mayor - www.gmayor.com
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not oFSO.FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Set oFSO = Nothing
    Exit Function
End Function