Visual Basic

'// ========================================================
Option Explicit
'[Constants]
Const kExportPath = "C:\My Email\" ' path must exist!
'// ========================================================
'[Support]
Sub ExportMessages()
' variables
Dim OL As Outlook.Application ' Outlook instance
Dim exp As Explorer
Dim ols As Selection
Dim mu As Redemption.MAPIUtils
Dim mi 'As MailItem
Dim lIter&

' toggle commenting on the following two lines to use
' from VB vs Outlook:
'Set OL = CreateObject("Outlook.Application") '// VB
Set OL = ThisOutlookSession '// Outlook

' ignore errors
'On Error Resume Next

' get handle to selection
If Outlook.ActiveExplorer Is Nothing Then Exit Sub
Set exp = Outlook.ActiveExplorer
Set ols = exp.Selection
Set mu = New Redemption.MAPIUtils

For lIter = 1 To ols.Count
Set mi = ols.Item(lIter)
' do it
SaveCDOMessage mi.EntryID
' clean up
Set mi = Nothing
Next lIter
' clean up
Set mi = Nothing
mu.Cleanup
Set mu = Nothing
Set ols = Nothing
Set exp = Nothing
Set OL = Nothing
End Sub
'// ========================================================
Sub SaveCDOMessage(sEntryID)
Dim mu As Redemption.MAPIUtils
Dim objMsg As Redemption.MessageItem
Dim sFilename$, sHeader$, sContents$, aContents
Dim fso As New FileSystemObject
Dim ts As TextStream
sFilename = kExportPath & sEntryID & ".mai"

On Error Resume Next
' export the message
Set mu = CreateObject("Redemption.MAPIUtils")
mu.MAPIOBJECT = Session.MAPIOBJECT
Set objMsg = mu.GetItemFromID(sEntryID)
objMsg.SaveAs sFilename, olRFC822
'objMsg.SaveAs sFilename, olRTF
'objMsg.SaveAs sFilename, olHTML
'objMsg.SaveAs sFilename, olMSG
'objMsg.SaveAs sFilename, olDoc
'objMsg.SaveAs sFilename, olTXT
'objMsg.SaveAs sFilename, olMSGUnicode

' update headers in exported file
sHeader = objMsg.Fields(8192030)
Set ts = fso.OpenTextFile(sFilename, ForReading, True)
sContents = ts.ReadAll
ts.Close
aContents = Split(sContents, vbCrLf & vbCrLf, 2, 1)
aContents(0) = sHeader
Set ts = fso.OpenTextFile(sFilename, ForWriting, True)
ts.Write Join(aContents, vbCrLf & vbCrLf)
ts.Close
Set ts = Nothing

' clean up
Set objMsg = Nothing
mu.Cleanup
Set mu = Nothing
Set fso = Nothing
End Sub
'// ========================================================